Skip to content
Browse files

fix of missing type synonym expansion of assumed class predicates; cl…

…eaning up CHR solving code, more documentation
  • Loading branch information...
1 parent 90410f5 commit e8db0dbd0d090d91f7020535e661405df63f54fa atze committed Feb 3, 2012
View
16 EHC/Makefile
@@ -300,11 +300,9 @@ uhc-install-postprocess-llvm:
###########################################################################################
uhc-dist: uhc
- @distnm="$(UHC_INSTALL_VARIANTNAME)-R$(subst :,-,$(SVN_REVISION))-$(DATE)-$(HOST_PLATFORM_NRWORDBITS)-$(HOST_PLATFORM_NAME)" && \
+ @distnm="$(UHC_INSTALL_VARIANTNAME)-$(subst :,-,$(SVN_REVISION))-$(DATE)-$(HOST_PLATFORM_NRWORDBITS)-$(HOST_PLATFORM_NAME)" && \
distdir="$(DISTABS_PREFIX)$${distnm}" && \
mkdir -p $${distdir} && \
- echo $${distnm} && \
- echo $(UHC_INSTALL_VARIANT_PREFIX) $(UHC_INSTALL_PREFIX) && \
$(call FUN_INSTALLUHC_COPY,$(UHC_INSTALL_VARIANT_PREFIX),$${distdir}/dist/) && \
echo "Generating install (make, config, ...) files to $${distdir} ..." && \
mkdir -p $(UHC_INSTALL_VARIANT_PREFIX) && \
@@ -322,23 +320,25 @@ uhc-dist: uhc
echo 'DIST_EHCBINARY:=$$(DIST_INSTALL_PREFIX)bin/'"$(EHC_EXEC_NAME)$(EXEC_SUFFIX)" && \
echo 'DIST_UHCSHELL:=$$(DIST_BIN_PREFIX)'"$(UHC_EXEC_NAME)" && \
echo "" && \
+ echo "default:" && \
+ echo " @echo This is a binary distribution, UHC is already built, install with \'make install\'" && \
+ echo "" && \
echo "install:" && \
- echo ' @echo Copying files to $$(DIST_INSTALL_PREFIX) ...' && \
+ echo ' @echo Installing files to $$(DIST_INSTALL_PREFIX) ...' && \
echo ' @$$(call FUN_COPY_FILES_BY_TAR,dist,$$(DIST_INSTALL_PREFIX),*)' && \
echo ' @$$(call FUN_INSTALLUHC_WRAPPER,$$(DIST_EHCBINARY),$$(DIST_UHCSHELL),$$(DIST_BIN_PREFIX),$$(DIST_LIB_PREFIX),'"$(UHC_INSTALL_VARIANTNAME)"')' && \
echo "" && \
echo "uninstall:" && \
echo ' @echo Removing installation $$(DIST_INSTALL_PREFIX) ...' && \
echo ' rm -rf $$(DIST_INSTALL_PREFIX) $$(DIST_UHCSHELL)' && \
- echo "" && \
- echo "# done" \
+ echo "" \
) > $${distdir}/Makefile.in && \
( echo "# installation configure, generated for $${distnm}" && \
echo "AC_INIT([UHC],[$(EH_VERSION_FULL)],[uhc-users@lists.science.uu.nl, http://www.cs.uu.nl/wiki/UHC/WebHome])" && \
echo 'AC_CANONICAL_HOST' && \
echo 'AC_CONFIG_FILES([Makefile])' && \
echo 'AC_OUTPUT' && \
- echo "# done" \
+ echo "" \
) > $${distdir}/configure.ac && \
cp LICENSE README \
aclocal.m4 \
@@ -351,7 +351,7 @@ uhc-dist: uhc
cd $${distdir} && \
autoconf && \
cd .. && \
- echo "Building archive $${distnm}.tar.bz2 ..." && \
+ echo "Building distribution archive $${distnm}.tar.bz2 ..." && \
tar cfj $${distnm}.tar.bz2 $${distnm} && \
echo "Done"
View
8 EHC/README
@@ -9,11 +9,13 @@ about UHC is:
http://www.cs.uu.nl/wiki/UHC/WebHome
-Here the elaborate instructions for getting started and downloading can be found. The short version for installing uhc is:
+Here the elaborate instructions for getting started and downloading can
+be found. The short version for installing uhc (from either binary or
+source distribution) is:
./configure
- make
- make install
+ make # optional
+ make install # may require admin permission
More detailed information currently still labeled with EHC can be found
here:
View
2 EHC/SVNREVISION
@@ -1 +1 @@
-2422:2426M
+2430M
View
11 EHC/bin/ghci-uhc
@@ -0,0 +1,11 @@
+#!/bin/sh
+# invoke ghci on a uhc library
+variant=99
+module=$1
+ghci -ibuild/libutil:build/${variant}:build/${variant}/lib-ehc \
+ -package bytestring \
+ -XFlexibleContexts -XTypeSynonymInstances -XRankNTypes -XMultiParamTypeClasses \
+ -XMultiParamTypeClasses -XFunctionalDependencies -XFlexibleInstances \
+ -XExistentialQuantification -XUndecidableInstances -XOverlappingInstances -XDeriveDataTypeable -XLiberalTypeSynonyms \
+ -XScopedTypeVariables -XStandaloneDeriving \
+ ${module} # build/${variant}/EHC.hs
View
5 EHC/src/ehc/Base/Common.chs
@@ -1039,10 +1039,9 @@ data Presence = Present | Absent deriving (Eq,Ord,Show)
%%% Combinations
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-Combine [[x1..xn],..,[y1..ym]] to [[x1..y1],[x1..y2],..,[xn..ym]].
-Each element [xi..yi] is distinct based on the the key k in xi==(k,_)
-
%%[9 export(combineToDistinguishedElts)
+-- | Combine [[x1..xn],..,[y1..ym]] to [[x1..y1],[x2..y1],..,[xn..ym]].
+-- Each element [xi..yi] is distinct based on the the key k in xi==(k,_)
combineToDistinguishedElts :: Eq k => [AssocL k v] -> [AssocL k v]
combineToDistinguishedElts [] = []
combineToDistinguishedElts [[]] = []
View
3 EHC/src/ehc/CHR.chs
@@ -2,8 +2,10 @@
%%% Constraint Handling Rules
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%[doesWhat doclatex
Derived from work by Gerrit vd Geest, but with searching structures for predicates
to avoid explosion of search space during resolution.
+%%]
%%[(9 hmtyinfer || hmtyast) module {%{EH}CHR} import(qualified {%{EH}Base.Trie} as Trie,{%{EH}Base.Common},{%{EH}Substitutable},{%{EH}VarMp})
%%]
@@ -28,6 +30,7 @@ to avoid explosion of search space during resolution.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%[(9 hmtyinfer || hmtyast) export(CHR(..))
+-- | A CHR (rule) consist of head (simplification + propagation, boundary indicated by an Int), guard, and a body. All may be empty, but not all at the same time.
data CHR cnstr guard subst
= CHR
{ chrHead :: ![cnstr]
View
36 EHC/src/ehc/CHR/Constraint.chs
@@ -30,6 +30,7 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%[(9 hmtyinfer || hmtyast) export(Constraint(..))
+-- | A Constraint is abstracted over the exact predicate, but differentiates on the role: to prove, can be assumed, and side effect of reduction
data Constraint p info
= Prove { cnstrPred :: !p } -- proof obligation
| Assume { cnstrPred :: !p } -- assumed constraint
@@ -58,29 +59,30 @@ deriving instance Typeable2 Constraint
deriving instance (Data x, Data y) => Data (Constraint x y)
%%]
-%%[(9 hmtyinfer || hmtyast)
-reducablePart :: Constraint p info -> Maybe (String,p,p->Constraint p info)
-reducablePart (Prove p) = Just ("Prf",p,Prove)
-reducablePart (Assume p) = Just ("Ass",p,Assume)
-reducablePart _ = Nothing
+%%[(9 hmtyinfer || hmtyast) export(constraintReducablePart)
+-- | Dissection of Constraint, including reconstruction function
+constraintReducablePart :: Constraint p info -> Maybe (String,p,p->Constraint p info)
+constraintReducablePart (Prove p) = Just ("Prf",p,Prove)
+constraintReducablePart (Assume p) = Just ("Ass",p,Assume)
+constraintReducablePart _ = Nothing
%%]
%%[(9 hmtyinfer || hmtyast)
instance Keyable p => Keyable (Constraint p info) where
- toKey c = maybe [] (\(s,p,_) -> TK_One TKK_Normal (Key_Str s) : toKey p) $ reducablePart c
+ toKey c = maybe [] (\(s,p,_) -> TK_One TKK_Normal (Key_Str s) : toKey p) $ constraintReducablePart c
instance (CHRMatchable env p s) => CHRMatchable env (Constraint p info) s where
chrMatchTo env s c1 c2
- = do { (_,p1,_) <- reducablePart c1
- ; (_,p2,_) <- reducablePart c2
+ = do { (_,p1,_) <- constraintReducablePart c1
+ ; (_,p2,_) <- constraintReducablePart c2
; chrMatchTo env s p1 p2
}
%%]
%%[(9 hmtyinfer || hmtyast)
instance (VarExtractable p v,VarExtractable info v) => VarExtractable (Constraint p info) v where
varFreeSet c
- = case reducablePart c of
+ = case constraintReducablePart c of
Just (_,p,_) -> varFreeSet p
_ -> Set.empty
@@ -129,6 +131,7 @@ instance (PP p, PP info) => PP (UnresolvedTrace p info) where
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%[(9 hmtyinfer || hmtyast)
+-- | Map from constraint to something
type ConstraintMp' p info x = Map.Map (Constraint p info) [x]
%%]
@@ -141,6 +144,7 @@ cnstrMpMap f = Map.map (map f)
%%]
%%[(9 hmtyinfer || hmtyast) export(ConstraintToInfoTraceMp)
+-- | Map from constraint to info + trace
type ConstraintToInfoTraceMp p info = ConstraintMp' p info (info,UnresolvedTrace p info)
%%]
@@ -155,9 +159,12 @@ cnstrTraceMpLiftTrace :: (Ord p, Ord i) => ConstraintToInfoMap p i -> Constraint
cnstrTraceMpLiftTrace = cnstrMpMap (\x -> (x,UnresolvedTrace_None))
%%]
-%%[(9 hmtyinfer || hmtyast) export(ConstraintToInfoMap,emptyCnstrMp)
+%%[(9 hmtyinfer || hmtyast) export(ConstraintToInfoMap)
+-- | Map from constraint to info
type ConstraintToInfoMap p info = ConstraintMp' p info info
+%%]
+%%[(9 hmtyinfer || hmtyast) export(emptyCnstrMp)
emptyCnstrMp :: ConstraintMp' p info x
emptyCnstrMp = Map.empty
%%]
@@ -176,18 +183,11 @@ cnstrMpUnions = Map.unionsWith (++)
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% Rule
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[(9 hmtyinfer || hmtyast) export(CHRRule)
-type CHRRule p g s info = CHR (Constraint p info) g s
-%%]
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Observations
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%[(9 hmtyinfer || hmtyast) export(cnstrRequiresSolve)
+-- | Predicate for whether solving is required
cnstrRequiresSolve :: Constraint p info -> Bool
cnstrRequiresSolve (Reduction {}) = False
cnstrRequiresSolve _ = True
View
162 EHC/src/ehc/CHR/Solve.chs
@@ -47,6 +47,7 @@ type UsedByKey = (CHRKey,Int)
%%]
%%[(9 hmtyinfer || hmtyast) export(CHRStore,emptyCHRStore)
+-- | A CHR as stored in a CHRStore, requiring additional info for efficiency
data StoredCHR p i g s
= StoredCHR
{ storedChr :: !(CHR (Constraint p i) g s) -- the CHR
@@ -58,9 +59,11 @@ data StoredCHR p i g s
deriving (Typeable, Data)
%%]]
+-- | The size of the simplification part of a CHR
storedSimpSz :: StoredCHR p i g s -> Int
storedSimpSz = chrSimpSz . storedChr
+-- | A CHR store is a trie structure
newtype CHRStore pred info guard subst
= CHRStore
{ chrstoreTrie :: Trie.Trie Key [StoredCHR pred info guard subst]
@@ -76,6 +79,7 @@ emptyCHRStore = mkCHRStore Trie.empty
%%]
%%[(9 hmtyinfer || hmtyast)
+-- | Combine lists of stored CHRs by concat, adapting their identification nr to be unique
cmbStoredCHRs :: [StoredCHR p i g s] -> [StoredCHR p i g s] -> [StoredCHR p i g s]
cmbStoredCHRs s1 s2
= map (\s@(StoredCHR {storedIdent=(k,nr)}) -> s {storedIdent = (k,nr+l)}) s1 ++ s2
@@ -102,6 +106,7 @@ instance (PP p, PP i, PP g) => PP (StoredCHR p i g s) where
%%]
%%[(9 hmtyinfer || hmtyast) export(chrStoreFromElems,chrStoreUnion,chrStoreUnions,chrStoreSingletonElem)
+-- | Convert from list to store
chrStoreFromElems :: Keyable p => [CHR (Constraint p i) g s] -> CHRStore p i g s
chrStoreFromElems chrs
= mkCHRStore
@@ -168,17 +173,22 @@ initWorkTime = 0
type WorkKey = CHRKey
-- type WorkUsedInMap = Map.Map CHRKey (Set.Set UsedByKey)
type WorkUsedInMap = Map.Map (Set.Set CHRKey) (Set.Set UsedByKey)
+type WorkTrie p i = Trie.Trie Key (Work p i)
+-- | A chunk of work to do when solving, a constraint + sequence nr
data Work p i
= Work
{ workCnstr :: !(Constraint p i) -- the constraint to be reduced
, workTime :: WorkTime -- the history count at which the work was added
-- , workUsedIn :: Set.Set CHRKey -- marked with the propagation rules already applied to it
}
+-- | The work to be done (wlQueue), also represented as a trie (wlTrie) because efficient check on already worked on is needed.
+-- A done set (wlDoneSet) remembers which CHRs (itself a list of constraints) have been solved.
+-- To prevent duplicate propagation a mapping from CHRs to a map (wlUsedIn) to the CHRs it is used in is maintained.
data WorkList p i
= WorkList
- { wlTrie :: !(Trie.Trie Key (Work p i))
+ { wlTrie :: !(WorkTrie p i)
, wlDoneSet :: !(Set.Set WorkKey) -- accumulative store of all keys added, set semantics, thereby avoiding double entry
, wlQueue :: !(AssocL WorkKey (Work p i))
, wlScanned :: !(AssocL WorkKey (Work p i)) -- tried but could not solve, so retry when other succeeds
@@ -413,7 +423,7 @@ chrSolve' env chrStore cnstrs
%%[(9 hmtyinfer || hmtyast) export(chrSolve'')
chrSolve''
- :: -- forall env p i g s .
+ :: forall env p i g s .
( CHRMatchable env p s, CHRCheckable env g s
-- , VarUpdatable s s, VarUpdatable g s, VarUpdatable i s, VarUpdatable p s
, VarLookupCmb s s
@@ -475,7 +485,7 @@ chrSolve'' env chrStore cnstrs prevState
%%][100
= expandMatch st' tlMatchY
%%]]
- where (tlMatchY,tlMatchN) = partition (\(r@(_,(ks,_)),_) -> not (any (`elem` keysSimp) ks || isUsedByPropPart (wlUsedIn wl') r)) tlMatch
+ where (tlMatchY,tlMatchN) = partition (\(r@(_,(ks,_)),_) -> not (any (`elem` keysSimp) ks || slvIsUsedByPropPart (wlUsedIn wl') r)) tlMatch
(keysSimp,keysProp) = splitAt simpSz keys
usedIn = Map.singleton (Set.fromList keysProp) (Set.singleton chrId)
(bTodo,bDone) = splitDone $ map (varUpd subst) b
@@ -552,56 +562,128 @@ chrSolve'' env chrStore cnstrs prevState
, Map.empty
%%]]
)
- where -- cache result
+ where -- cache result, if present use that, otherwise the below computation
mbInCache = Map.lookup workHdKey (stMatchCache st)
- -- results
- r2 = concat $ lookupResultToList $ lookupPartialByKey TrieLookup_Partial workHdKey $ chrstoreTrie chrStore
- r23 = map (\c -> (c,candidate c)) r2
- r3 = concatMap (\(c,cands) -> zip (repeat c) (map unzip $ combine cands)) $ r23
- r4 = filter (not . isUsedByPropPart wlUsedIn) r3
- r5 = mapMaybe (\r@(chr,kw@(_,works)) -> fmap (\s -> (r,s)) $ match chr (map workCnstr works)) r4
+
+ -- results, stepwise computed for later reference in debugging output
+ -- basic search result
+ r2 :: [StoredCHR p i g s] -- CHRs matching workHdKey
+ r2 = concat -- flatten
+ $ lookupResultToList -- convert to list
+ $ lookupPartialByKey TrieLookup_Partial workHdKey -- lookup the store, allowing too many results
+ $ chrstoreTrie chrStore
+
+ -- lookup further info in wlTrie, in particular to find out what has been done already
+ r23 :: [( StoredCHR p i g s -- the CHR
+ , ( [( [(CHRKey, Work p i)] -- for each CHR the list of constraints, all possible work matches
+ , [(CHRKey, Work p i)]
+ )]
+ , (CHRKey, Set.Set CHRKey)
+ ) )]
+ r23 = map (\c -> (c, slvCandidate workHdKey lastQuery wlTrie c)) r2
+
+ -- possible matches
+ r3, r4
+ :: [( StoredCHR p i g s -- the matched CHR
+ , ( [CHRKey] -- possible matching constraints (matching with the CHR constraints), as Keys, as Works
+ , [Work p i]
+ ) )]
+ r3 = concatMap (\(c,cands) -> zip (repeat c) (map unzip $ slvCombine cands)) $ r23
+
+ -- same, but now restricted to not used earlier as indicated by the worklist
+ r4 = filter (not . slvIsUsedByPropPart wlUsedIn) r3
+
+ -- finally, the 'real' match of the 'real' constraint, yielding (by tupling) substitutions instantiating the found trie matches
+ r5 :: [( ( StoredCHR p i g s
+ , ( [CHRKey]
+ , [Work p i]
+ ) )
+ , s
+ )]
+ r5 = mapMaybe (\r@(chr,kw@(_,works)) -> fmap (\s -> (r,s)) $ slvMatch env chr (map workCnstr works)) r4
%%[[9
+ -- debug info
pp2 = "lookups" >#< ("for" >#< ppTrieKey workHdKey >-< ppBracketsCommasV r2)
-- pp2b = "cand1" >#< (ppBracketsCommasV $ map (ppBracketsCommasV . map (ppBracketsCommasV . map (\(k,w) -> ppTrieKey k >#< w)) . fst . candidate) r2)
-- pp2c = "cand2" >#< (ppBracketsCommasV $ map (ppBracketsCommasV . map (ppBracketsCommasV) . combineToDistinguishedElts . fst . candidate) r2)
pp3 = "candidates" >#< (ppBracketsCommasV $ map (\(chr,(ks,ws)) -> "chr" >#< chr >-< "keys" >#< ppBracketsCommas (map ppTrieKey ks) >-< "works" >#< ppBracketsCommasV ws) $ r3)
%%][100
%%]]
- -- util functions
- candidate (StoredCHR {storedIdent = (ck,_), storedKeys = ks, storedChr = chr})
- = (cand lkup ks, (ck,queriedWorkS))
- where lkup how k = partition (\(_,w) -> workTime w < lastQueryTm) $ lookupResultToList $ lookupPartialByKey' (,) how k wlTrie
- where lastQueryTm = lqLookupW k lastQueryW
- cand lkup = map (maybe (lkup TrieLookup_Normal workHdKey) (lkup TrieLookup_StopAtPartial))
- lastQueryW = lqLookupC ck lastQuery
- queriedWorkS = Set.fromList $ map (maybe workHdKey id) ks
- combine ([],_) = []
- combine ((lh:lt),_)
- = concatMap combineToDistinguishedElts l2
- -- = combineToDistinguishedElts $ map (\(bef,aft) -> bef++aft) l
- where l2 = g2 [] lh lt
- where g2 ll l [] = [mk ll l []]
- g2 ll l lr@(lrh:lrt) = mk ll l lr : g2 (ll ++ [l]) lrh lrt
- mk ll (bef,aft) lr = map fst ll ++ [aft] ++ map cmb lr
- where cmb (a,b) = a++b
- match chr cnstrs
- = foldl cmb (Just chrEmptySubst) $ matches chr cnstrs ++ checks chr
- where matches (StoredCHR {storedChr = CHR {chrHead = hc}}) cnstrs
- = zipWith mt hc cnstrs
- where mt cFr cTo subst = chrMatchTo env subst cFr cTo
- checks (StoredCHR {storedChr = CHR {chrGuard = gd}})
- = map chk gd
- where chk g subst = chrCheck env subst g
- cmb (Just s) next = fmap (|+> s) $ next s
- cmb _ _ = Nothing
- isUsedByPropPart wlUsedIn (chr,(keys,_))
- = fnd $ drop (storedSimpSz chr) keys
- where fnd k = maybe False (storedIdent chr `Set.member`) $ Map.lookup (Set.fromList k) wlUsedIn
initState st = st { stWorkList = wlInsert (stHistoryCount st) wlnew $ stWorkList st, stDoneCnstrSet = Set.unions [Set.fromList done, stDoneCnstrSet st] }
where (wlnew,done) = splitDone cnstrs
splitDone = partition cnstrRequiresSolve
%%]
+%%[(9 hmtyinfer || hmtyast)
+-- | Extract candidates matching a CHRKey.
+-- Return a list of CHR matches,
+-- each match expressed as the list of constraints (in the form of Work + Key) found in the workList wlTrie, thus giving all combis with constraints as part of a CHR,
+-- partititioned on before or after last query time (to avoid work duplication later)
+slvCandidate
+ :: CHRKey
+ -> LastQuery
+ -> WorkTrie p i
+ -> StoredCHR p i g s
+ -> ( [( [(CHRKey, Work p i)]
+ , [(CHRKey, Work p i)]
+ )]
+ , (CHRKey, Set.Set CHRKey)
+ )
+slvCandidate workHdKey lastQuery wlTrie (StoredCHR {storedIdent = (ck,_), storedKeys = ks, storedChr = chr})
+ = ( map (maybe (lkup TrieLookup_Normal workHdKey) (lkup TrieLookup_StopAtPartial)) ks
+ , ( ck
+ , Set.fromList $ map (maybe workHdKey id) ks
+ ) )
+ where lkup how k = partition (\(_,w) -> workTime w < lastQueryTm) $ lookupResultToList $ lookupPartialByKey' (,) how k wlTrie
+ where lastQueryTm = lqLookupW k $ lqLookupC ck lastQuery
+%%]
+
+%%[(9 hmtyinfer || hmtyast)
+slvCombine :: Eq k => ([([Assoc k v], [Assoc k v])], t) -> [AssocL k v]
+slvCombine ([],_) = []
+slvCombine ((lh:lt),_)
+ = concatMap combineToDistinguishedElts l2
+ where l2 = g2 [] lh lt
+ where g2 ll l [] = [mk ll l []]
+ g2 ll l lr@(lrh:lrt) = mk ll l lr : g2 (ll ++ [l]) lrh lrt
+ mk ll (bef,aft) lr = map fst ll ++ [aft] ++ map cmb lr
+ where cmb (a,b) = a++b
+%%]
+
+%%[(9 hmtyinfer || hmtyast)
+-- | Check whether the CHR propagation part of a match already has been used (i.e. propagated) earlier,
+-- this to avoid duplicate propagation.
+slvIsUsedByPropPart
+ :: Ord k
+ => Map.Map (Set.Set k) (Set.Set UsedByKey)
+ -> (StoredCHR p i g s, ([k], t))
+ -> Bool
+slvIsUsedByPropPart wlUsedIn (chr,(keys,_))
+ = fnd $ drop (storedSimpSz chr) keys
+ where fnd k = maybe False (storedIdent chr `Set.member`) $ Map.lookup (Set.fromList k) wlUsedIn
+%%]
+
+%%[(9 hmtyinfer || hmtyast)
+-- | Match the stored CHR with a set of possible constraints, giving a substitution on success
+slvMatch
+ :: ( CHREmptySubstitution s
+ , CHRMatchable env p s
+ , CHRCheckable env g s
+ , VarLookupCmb s s
+ )
+ => env -> StoredCHR p i g s -> [Constraint p i] -> Maybe s
+slvMatch env chr cnstrs
+ = foldl cmb (Just chrEmptySubst) $ matches chr cnstrs ++ checks chr
+ where matches (StoredCHR {storedChr = CHR {chrHead = hc}}) cnstrs
+ = zipWith mt hc cnstrs
+ where mt cFr cTo subst = chrMatchTo env subst cFr cTo
+ checks (StoredCHR {storedChr = CHR {chrGuard = gd}})
+ = map chk gd
+ where chk g subst = chrCheck env subst g
+ cmb (Just s) next = fmap (|+> s) $ next s
+ cmb _ _ = Nothing
+%%]
+
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Instance: ForceEval, Serialize
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
View
7 EHC/src/ehc/Core/Pretty.cag
@@ -89,7 +89,12 @@ ppOptCMetas x
%%[(9 codegen) hs export(ppCBindL)
ppCBindL :: CBindL -> PP_Doc
-ppCBindL = ppAssocL . map (\(CBind_Bind n [CBindAspect_Bind m v]) -> (n,v >|< ppOptCMetas m))
+ppCBindL
+ = ppAssocL
+ . map (\b -> case b of
+ CBind_Bind n [CBindAspect_Bind m v] -> (n,v >|< ppOptCMetas m)
+ CBind_Bind n _ -> (n,pp "..")
+ )
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
View
9 EHC/src/ehc/EH/ResolvePredCHR.cag
@@ -259,9 +259,16 @@ simplify' simplifyHow chrStore clDfGam heur partitionUnresolved2AmbigAndOthers t
; return ()
}
- where canon s (Prove p) = (Prove $ p {cpoPr = p'}, m)
+ where {-
+ canon s (Prove p) = (Prove $ p {cpoPr = p'}, m)
where (p',m) = predCanonic (simpEnv s) $ cpoPr p
canon s c = (c, emptyVarMp)
+ -}
+ canon s c
+ = case constraintReducablePart c of
+ Just (_,p,mkc) -> (mkc $ p {cpoPr = p'}, m)
+ where (p',m) = predCanonic (simpEnv s) $ cpoPr p
+ _ -> (c, emptyVarMp)
-- basic simplification of reduction graph
basicSimpRedGraph chrSolveAllCnstrMp
View
2 EHC/src/ehc/Gam/ClassDefaultGam.chs
@@ -49,7 +49,7 @@ type ClassDefaultGam = Gam HsName ClassDefaultGamInfo
%%[(9 hmtyinfer || hmtyast) export(clDfGamLookupDefault)
-- | Lookup a matching default for a predicate
clDfGamLookupDefault
- :: ( VarLookup gm LabelVarId VarMpInfo
+ :: ( VarLookup gm TyVarId VarMpInfo
-- , VarLookup gm Ty VarMpInfo
, VarLookupCmb VarMp gm
)
View
4 EHC/src/ehc/Ty/FitsIn.chs
@@ -1754,8 +1754,8 @@ fitsInFold opts env uniq varmp tyl
%%[(9 hmtyinfer) export(fitPredIntoPred)
fitPredIntoPred
- :: ( VarLookup gm LabelVarId VarMpInfo
- , VarLookupCmb VarMp gm
+ :: ( VarLookupCmb VarMp gm
+ , VarLookup gm TyVarId VarMpInfo
)
=> FIIn' gm -> Pred -> Pred
-> Maybe (Pred,VarMp)
View
2 EHC/src/ehc/Ty/Trf/Subst.cag
@@ -227,7 +227,7 @@ SEM Pred
loc . needRepl = case @tvUse of
TVFree -> @isRepl
_ -> False
- inst . repl' = if @needRepl then @replv else Pred_Preds PredSeq_Nil
+ inst . repl' = if @needRepl then @replv else Pred_Pred Ty_Any
%%]
%%[(10 hmtyinfer || hmtyast)
View
25 EHC/test/regress/99/TySyn3.hs
@@ -0,0 +1,25 @@
+{- ----------------------------------------------------------------------------------------
+ what : type synonym, in particular proper deep enough expansion of assumptions in ty signature,
+ expected: ok, no output, no errors
+---------------------------------------------------------------------------------------- -}
+
+module TySyn3 where
+
+class ToJS a b where
+ toJS :: a -> b
+
+instance ToJS String JSString where
+ toJS = undefined
+
+type JSString = Bool --PackedString
+
+data CSSStyleDeclaration
+
+-- JSString in assumption ToJS a JSString should be expanded properly
+cssSetPropertyValue :: ToJS a JSString => CSSStyleDeclaration -> String -> a -> IO ()
+cssSetPropertyValue c p v = _cssSetPropertyValue c (toJS p) (toJS v)
+
+_cssSetPropertyValue :: CSSStyleDeclaration -> JSString -> JSString -> IO ()
+_cssSetPropertyValue = undefined
+
+main = return ()

0 comments on commit e8db0db

Please sign in to comment.
Something went wrong with that request. Please try again.