ghc-exactprint 0.4.1.0 → 0.4.2.0
raw patch · 17 files changed
+100/−498 lines, 17 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog +2/−1
- ghc-exactprint.cabal +1/−1
- src/Language/Haskell/GHC/ExactPrint/Annotate.hs +20/−8
- src/Language/Haskell/GHC/ExactPrint/Delta.hs +1/−1
- src/Language/Haskell/GHC/ExactPrint/Lookup.hs +1/−1
- tests/Test.hs +2/−0
- tests/examples/AddLocalDecl7.hs +9/−0
- tests/examples/AddLocalDecl7.hs.expected +11/−0
- tests/examples/Arrow2.hs +53/−0
- tests/examples/Base.hs +0/−26
- tests/examples/Error.hs +0/−110
- tests/examples/Join.hs +0/−7
- tests/examples/Lambda.hs +0/−2
- tests/examples/NormaliseLayout.hs +0/−5
- tests/examples/NormaliseLayout.hs.expected +0/−1
- tests/examples/SegFault.hs +0/−133
- tests/examples/SegFault2.hs +0/−202
ChangeLog view
@@ -1,6 +1,7 @@+2015-11-15 v0.4.2+ * Fix round tripping of arrow notation using ">-" and ">>-". 2015-09-28 v0.4.1 * Revert removing cast from markLocated until further inspection in HaRe.- 2015-09-28 v0.4.0.0 * Rework HasDecls so that there are only instances for which it is idempotent. Provide functions for managing an LHsBind which is not
ghc-exactprint.cabal view
@@ -1,5 +1,5 @@ name: ghc-exactprint-version: 0.4.1.0+version: 0.4.2.0 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 7.10.2, this library provides a means to round trip any code that can
src/Language/Haskell/GHC/ExactPrint/Annotate.hs view
@@ -1902,15 +1902,21 @@ mark GHC.AnnStatic markLocated e - markAST _ (GHC.HsArrApp e1 e2 _ _ _) = do- markLocated e1- -- only one of the next 4 will be resent+ markAST _ (GHC.HsArrApp e1 e2 _ _ isRightToLeft) = do+ -- isRightToLeft True => right-to-left (f -< arg)+ -- False => left-to-right (arg >- f)+ if isRightToLeft+ then markLocated e1+ else markLocated e2+ -- only one of the next 4 will be present mark GHC.Annlarrowtail mark GHC.Annrarrowtail mark GHC.AnnLarrowtail mark GHC.AnnRarrowtail - markLocated e2+ if isRightToLeft+ then markLocated e2+ else markLocated e1 markAST _ (GHC.HsArrForm e _ cs) = do markWithString GHC.AnnOpen "(|"@@ -1991,15 +1997,21 @@ instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsCmd name) where- markAST _ (GHC.HsCmdArrApp e1 e2 _ _ _) = do- markLocated e1- -- only one of the next 4 will be resent+ markAST _ (GHC.HsCmdArrApp e1 e2 _ _ isRightToLeft) = do+ -- isRightToLeft True => right-to-left (f -< arg)+ -- False => left-to-right (arg >- f)+ if isRightToLeft+ then markLocated e1+ else markLocated e2+ -- only one of the next 4 will be present mark GHC.Annlarrowtail mark GHC.Annrarrowtail mark GHC.AnnLarrowtail mark GHC.AnnRarrowtail - markLocated e2+ if isRightToLeft+ then markLocated e2+ else markLocated e1 markAST _ (GHC.HsCmdArrForm e _mf cs) = do markWithString GHC.AnnOpen "(|"
src/Language/Haskell/GHC/ExactPrint/Delta.hs view
@@ -494,7 +494,7 @@ , GHC.Annlarrowtail , GHC.Annrarrowtail , GHC.AnnLarrowtail- , GHC.AnnLarrowtail]+ , GHC.AnnRarrowtail] checkUnicode kwid _ = kwid -- ---------------------------------------------------------------------
src/Language/Haskell/GHC/ExactPrint/Lookup.hs view
@@ -96,7 +96,7 @@ (G GHC.AnnVbar ) -> "|" (G GHC.AnnWhere ) -> "where" (G GHC.Annlarrowtail ) -> "-<"- (G GHC.Annrarrowtail ) -> "->"+ (G GHC.Annrarrowtail ) -> ">-" (G GHC.AnnLarrowtail ) -> "-<<" (G GHC.AnnRarrowtail ) -> ">>-" (G GHC.AnnSimpleQuote ) -> "'"
tests/Test.hs view
@@ -58,6 +58,7 @@ , mkTestMod "Annotations.hs" "Annotations" , mkTestMod "Arrow.hs" "Arrow" , mkParserTest "Arrows.hs"+ , mkParserTest "Arrow2.hs" , mkTestMod "Associated.hs" "Main" , mkTestMod "B.hs" "Main" , mkTestMod "C.hs" "C"@@ -497,6 +498,7 @@ -- , manipulateAstTestWFnameMod cloneDecl1 "CloneDecl1.hs" "CloneDecl1" -- , manipulateAstTestWFname "SimpleDo.hs" "Main" -- , manipulateAstTestWFnameMod changeRename2 "Rename2.hs" "Main"+ , manipulateAstTestWFname "Arrow2.hs" "Arrow2" {- , manipulateAstTestWFname "Lhs.lhs" "Main" , manipulateAstTestWFname "Foo.hs" "Main"
+ tests/examples/AddLocalDecl7.hs view
@@ -0,0 +1,9 @@+module AddLocalDecl7 where++toplevel :: Integer -> Integer+toplevel x = c * x++-- c,d :: Integer+c = 7+d = 9+
+ tests/examples/AddLocalDecl7.hs.expected view
@@ -0,0 +1,11 @@+module AddLocalDecl7 where++toplevel :: Integer -> Integer+toplevel x = c * x+ where+ nn = nn2++-- c,d :: Integer+c = 7+d = 9+
+ tests/examples/Arrow2.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UnicodeSyntax #-}+module Arrow2 where++nonUnicode :: forall a . a -> IO Int+nonUnicode _ = do+ x <- readChar+ return 4++-- ^ An opaque ESD handle for recording data from the soundcard via ESD.+data Recorder fr ch (r ∷ * -> *)+ = Recorder {+ reCloseH :: !(FinalizerHandle r)+ }++f :: Arrow a => a (Int,Int,Int) Int+f = proc (x,y,z) -> returnA -< x+y++f2 :: Arrow a => a (Int,Int,Int) Int+f2 = proc (x,y,z) -> returnA >- x+y++g :: ArrowApply a => Int -> a (a Int Int,Int) Int+g y = proc (x,z) -> x -<< 2+y++g2 :: ArrowApply a => Int -> a (a Int Int,Int) Int+g2 y = proc (x,z) -> x >>- 2+y++-- -------------------------------------++unicode ∷ ∀ a . a → IO Int+unicode _ = do+ x ← readChar+ return 4++-- ^ An opaque ESD handle for recording data from the soundcard via ESD.+-- data RecorderU fr ch (r ∷ ★ → ★)+data RecorderU fr ch (r ∷ * → *)+ = RecorderU {+ reCloseHU ∷ !(FinalizerHandle r)+ }++fU :: Arrow a ⇒ a (Int,Int,Int) Int+fU = proc (x,y,z) -> returnA ⤙ x+y++f2U :: Arrow a ⇒ a (Int,Int,Int) Int+f2U = proc (x,y,z) -> returnA ⤚ x+y++gU :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int+gU y = proc (x,z) -> x ⤛ 2+y++g2U :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int+g2U y = proc (x,z) -> x ⤜ 2+y
− tests/examples/Base.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, RankNTypes, MagicHash, UnboxedTuples, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, UnliftedFFITypes #-}-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-#endif-{-# OPTIONS_HADDOCK hide #-}---- Flat unboxed arrays: instances--instance IArray UArray Bool where- {-# INLINE bounds #-}- bounds (UArray l u _ _) = (l,u)- {-# INLINE numElements #-}- numElements (UArray _ _ n _) = n- {-# INLINE unsafeArray #-}- unsafeArray lu ies = runST (unsafeArrayUArray lu ies False)- {-# INLINE unsafeAt #-}- unsafeAt (UArray _ _ _ arr#) (I# i#) =- ((indexWordArray# arr# (bOOL_INDEX i#) `and#` bOOL_BIT i#)- `neWord#` int2Word# 0#)-- {-# INLINE unsafeReplace #-}- unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)- {-# INLINE unsafeAccum #-}- unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)- {-# INLINE unsafeAccumArray #-}- unsafeAccumArray f initialValue lu ies = runST (unsafeAccumArrayUArray f initialValue lu ies)
− tests/examples/Error.hs
@@ -1,110 +0,0 @@--module GameData.Data where-#include "Utils.cpp"-import qualified Data.List as L-import qualified Data.List.Zipper as LZ-import Gamgine.Control (applyIf)-import qualified Gamgine.Zipper as GZ-import qualified GameData.Level as LV-import qualified GameData.Entity as E-IMPORT_LENS_AS_LE---data Data = Data {- levels :: LZ.Zipper LV.Level- }--LENS(levels)--instance E.ApplyToEntity Data where- eMap f = LE.modL currentLevelL (E.eMap f)- eFilter p = LE.modL currentLevelL (E.eFilter p)---currentLevelL = currentLevelLens-currentLevelLens = LE.lens getCurrentLevel setCurrentLevel- where- getCurrentLevel = LZ.cursor . levels- setCurrentLevel level = LE.modL levelsL $ LZ.replace level---newData :: [LV.Level] -> Data-newData = Data . LZ.fromList---allLevels :: Data -> [LV.Level]-allLevels = LZ.toList . levels---atLastLevel :: Data -> Bool-atLastLevel = GZ.atLast . levels---atFirstLevel :: Data -> Bool-atFirstLevel = GZ.atFirst . levels---levelFinished :: Data -> Bool-levelFinished = LV.allStarsCollected . LE.getL currentLevelL---gameFinished :: Data -> Bool-gameFinished d = levelFinished d && atLastLevel d---toNextLevel :: Data -> Data-toNextLevel d@Data {levels = lvs}- | LZ.emptyp lvs || GZ.atLast lvs = d- | otherwise =- let lvs = levels d- (c', n') = LV.changeLevels (GZ.current lvs) (GZ.next lvs)- in d {levels = LZ.replace n' . LZ.right . LZ.replace c' $ lvs}---toPreviousLevel :: Data -> Data-toPreviousLevel d@Data {levels = lvs}- | LZ.emptyp lvs || GZ.atFirst lvs = d- | otherwise =- let (c', p') = LV.changeLevels (GZ.current lvs) (GZ.previous lvs)- in d {levels = LZ.replace p' . LZ.left . LZ.replace c' $ lvs}---data AddLevel = BeforeCurrent | AfterCurrent | AfterLast--addEmptyLevel :: AddLevel -> Data -> Data-addEmptyLevel BeforeCurrent d@Data {levels = lvs} =- let (c', nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel- in d {levels = LZ.insert nlv' . LZ.replace c' $ lvs}--addEmptyLevel AfterCurrent d@Data {levels = lvs} =- let (c', nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel- in d {levels = LZ.insert nlv' . LZ.right . LZ.replace c' $ lvs}--addEmptyLevel AfterLast d@Data {levels = lvs} =- let (c', nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel- in d {levels = LZ.insert nlv' . LZ.end . LZ.replace c' $ lvs}---data MoveLevel = Forward | Backward--moveCurrentLevel :: MoveLevel -> Data -> Data-moveCurrentLevel Forward d@Data {levels = lvs}- | LZ.beginp lvs = d- | otherwise =- let (p, c) = (GZ.previous lvs, GZ.current lvs)- in d {levels = LZ.replace c . LZ.left . LZ.replace p $ lvs}--moveCurrentLevel Backward d@Data {levels = lvs}- | GZ.atLast lvs = d- | otherwise =- let (c, n) = (GZ.current lvs, GZ.next lvs)- in d {levels = LZ.replace c . LZ.right . LZ.replace n $ lvs}---removeCurrentLevel :: Data -> Data-removeCurrentLevel d@Data {levels = lvs}- | GZ.atFirst lvs && GZ.atLast lvs =- let (_, nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel- in d {levels = LZ.replace nlv' lvs}-- | otherwise = d {levels = applyIf LZ.endp LZ.left . LZ.delete $ lvs}
− tests/examples/Join.hs
@@ -1,7 +0,0 @@--forkOS_entry :: StablePtr (IO ()) -> IO ()-forkOS_entry stableAction = do- action <- deRefStablePtr stableAction- action--
− tests/examples/Lambda.hs
@@ -1,2 +0,0 @@--i = \x -> x
− tests/examples/NormaliseLayout.hs
@@ -1,5 +0,0 @@-module Main where--foo x = baz- where foo = 2- two = 4 where bax = 4
− tests/examples/NormaliseLayout.hs.expected
@@ -1,1 +0,0 @@-module Main where
− tests/examples/SegFault.hs
@@ -1,133 +0,0 @@-{-# INCLUDE "Parrot_hsc.h" #-}-{-# LINE 1 "Parrot.hsc" #-}-{-# OPTIONS_GHC -fglasgow-exts -cpp -fno-full-laziness -fno-cse #-}-{-# LINE 2 "Parrot.hsc" #-}--{-# LINE 3 "Parrot.hsc" #-}--module Pugs.Embed.Parrot where-import Data.IORef-import System.Cmd-import System.Process-import System.Directory-import System.IO-import System.IO.Unsafe-import Data.Maybe-import Control.Monad-import Pugs.Compat (getEnv, _PUGS_HAVE_POSIX)-import Pugs.Internals (encodeUTF8)--findExecutable' :: String -> IO (Maybe FilePath)-findExecutable' cmd = do- dir <- getEnv "PARROT_PATH"- if isJust dir then (do- rv <- findExecutableInDirectory (fromJust dir) cmd- if isJust rv then return rv else findExecutable'') else do- findExecutable''- where- findExecutable'' = do- rv <- findExecutable cmd- if isJust rv then return rv else do- cwd <- getCurrentDirectory- rv <- findExecutableInDirectory cwd cmd- if isJust rv then return rv else do- return Nothing--findExecutableInDirectory :: FilePath -> FilePath -> IO (Maybe FilePath)-findExecutableInDirectory dir cmd = do- let file | _PUGS_HAVE_POSIX = dir ++ ('/':cmd)- | otherwise = dir ++ ('\\':cmd) ++ ".exe"- ok <- doesFileExist file- return $ if ok then (Just file) else Nothing--findParrot :: IO FilePath-findParrot = do- rv <- findExecutable' "parrot"- case rv of- Nothing -> fail "Cannot find the parrot executable in PATH"- Just cmd -> return cmd--evalParrotFile :: FilePath -> IO ()-evalParrotFile file = do- cmd <- findParrot- -- parrot -j is fatal on systems where jit is not supported,- -- so we use the next fastest CGP core.- args <- getEnv "PUGS_PARROT_OPTS"- let args' | isJust args && fromJust args /= "" = fromJust args- | otherwise = "-f"- rawSystem cmd [args', file]- return ()--evalParrot :: String -> IO ()-evalParrot str = do- tmp <- getTemporaryDirectory- (file, fh) <- openTempFile tmp "pugs.pir"- hPutStr fh str- hClose fh- evalParrotFile file- removeFile file--evalPGE :: FilePath -> String -> String -> [(String, String)] -> IO String-evalPGE path match rule subrules = do- (inp, out, err, pid) <- initPGE path- (`mapM` subrules) $ \(name, rule) -> do- let nameStr = escape name- ruleStr = escape rule- hPutStrLn inp $ unwords- ["add_rule", show (length nameStr), show (length ruleStr)]- hPutStrLn inp nameStr- hPutStrLn inp ruleStr- let matchStr = escape match- ruleStr = escape rule- hPutStrLn inp $ unwords- ["match", show (length matchStr), show (length ruleStr)]- hPutStrLn inp $ matchStr- hPutStrLn inp $ ruleStr- hFlush inp- rv <- hGetLine out- case rv of- ('O':'K':' ':sizeStr) -> do- size <- readIO sizeStr- rv <- sequence (replicate size (hGetChar out))- ln <- hGetLine out- return $ rv ++ ln- _ -> do- errMsg <- hGetContents err- rv <- waitForProcess pid- writeIORef _ParrotInterp Nothing- let msg | null errMsg = show rv- | otherwise = errMsg- fail $ "*** Running external 'parrot' failed:\n" ++ msg- where- escape = escape . encodeUTF8- _escape "" = ""- _escape ('\\':xs) = "\\\\" ++ _escape xs- _escape ('\n':xs) = "\\n" ++ _escape xs- _escape (x:xs) = (x:_escape xs)--initPGE :: FilePath -> IO ParrotInterp-initPGE path = do- rv <- readIORef _ParrotInterp- case rv of- Just interp@(_, _, _, pid) -> do- gone <- getProcessExitCode pid- if isNothing gone then return interp else do- writeIORef _ParrotInterp Nothing- initPGE path- Nothing -> do- cmd <- findParrot- interp <- runInteractiveProcess cmd ["run_pge.pir"] (Just path) Nothing- writeIORef _ParrotInterp (Just interp)- return interp--type ParrotInterp = (Handle, Handle, Handle, ProcessHandle)--{-# NOINLINE _ParrotInterp #-}-_ParrotInterp :: IORef (Maybe ParrotInterp)-_ParrotInterp = unsafePerformIO $ newIORef Nothing--_DoCompile :: Maybe (IORef (String -> FilePath -> String -> IO String))-_DoCompile = Nothing---{-# LINE 387 "Parrot.hsc" #-}
− tests/examples/SegFault2.hs
@@ -1,202 +0,0 @@-{-# LANGUAGE CPP #-}--module UHC.Light.Compiler.CHR.Constraint-( Constraint (..)-, mkReduction-, cnstrReducablePart-, UnresolvedTrace (..)-, cnstrMpSingletonL, cnstrMpFromList-, ConstraintToInfoTraceMp-, cnstrTraceMpSingleton, cnstrTraceMpLiftTrace, cnstrTraceMpElimTrace, cnstrTraceMpFromList-, ConstraintToInfoMap-, emptyCnstrMp-, cnstrMpUnion, cnstrMpUnions-, cnstrRequiresSolve )-where-import UHC.Light.Compiler.Base.Common-import UHC.Light.Compiler.Ty-import UHC.Light.Compiler.CHR-import UHC.Light.Compiler.CHR.Key-import UHC.Light.Compiler.Base.TreeTrie-import UHC.Light.Compiler.Substitutable-import UHC.Util.Pretty as PP-import UHC.Util.Utils-import qualified Data.Set as Set-import qualified Data.Map as Map-import UHC.Light.Compiler.VarMp-import Control.Monad-import UHC.Util.Binary-import UHC.Util.Serialize-import Data.Typeable-import Data.Generics (Data)-import UHC.Light.Compiler.Opts.Base-----{-# LINE 37 "src/ehc/CHR/Constraint.chs" #-}--- | 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- | Reduction -- 'side effect', residual info used by (e.g.) codegeneration- { cnstrPred :: !p -- the pred to which reduction was done- , cnstrInfo :: !info -- additional reduction specific info w.r.t. codegeneration- , cnstrFromPreds :: ![p] -- the preds from which reduction was done- , cnstrVarMp :: VarMp -- additional bindings for type (etc.) variables, i.e. improving substitution- }- deriving (Eq, Ord, Show)--{-# LINE 53 "src/ehc/CHR/Constraint.chs" #-}-mkReduction :: p -> info -> [p] -> Constraint p info-mkReduction p i ps- = Reduction p i ps- varlookupEmpty--{-# LINE 62 "src/ehc/CHR/Constraint.chs" #-}-#if __GLASGOW_HASKELL__ >= 708-deriving instance Typeable Constraint-#else-deriving instance Typeable2 Constraint-#endif-deriving instance (Data x, Data y) => Data (Constraint x y)--{-# LINE 71 "src/ehc/CHR/Constraint.chs" #-}--- | Dissection of Constraint, including reconstruction function-cnstrReducablePart :: Constraint p info -> Maybe (String,p,p->Constraint p info)-cnstrReducablePart (Prove p) = Just ("Prf",p,Prove)-cnstrReducablePart (Assume p) = Just ("Ass",p,Assume)-cnstrReducablePart _ = Nothing--{-# LINE 84 "src/ehc/CHR/Constraint.chs" #-}-instance (CHRMatchable env p s) => CHRMatchable env (Constraint p info) s where- chrMatchTo env s c1 c2- = do { (_,p1,_) <- cnstrReducablePart c1- ; (_,p2,_) <- cnstrReducablePart c2- ; chrMatchTo env s p1 p2- }--{-# LINE 93 "src/ehc/CHR/Constraint.chs" #-}-instance TTKeyable p => TTKeyable (Constraint p info) where- toTTKey' o c -- = maybe [] (\(s,p,_) -> ttkAdd (TT1K_One $ Key_Str s) [toTTKey' o p]) $ cnstrReducablePart c- = case cnstrReducablePart c of- Just (s,p,_) -> ttkAdd' (TT1K_One $ Key_Str s) cs- where (_,cs) = toTTKeyParentChildren' o p- _ -> panic "TTKeyable (Constraint p info).toTTKey'" -- ttkEmpty--{-# LINE 102 "src/ehc/CHR/Constraint.chs" #-}-instance (VarExtractable p v,VarExtractable info v) => VarExtractable (Constraint p info) v where- varFreeSet c- = case cnstrReducablePart c of- Just (_,p,_) -> varFreeSet p- _ -> Set.empty--instance (VarUpdatable p s,VarUpdatable info s) => VarUpdatable (Constraint p info) s where- varUpd s (Prove p ) = Prove (varUpd s p)- varUpd s (Assume p ) = Assume (varUpd s p)- varUpd s r@(Reduction {cnstrPred=p, cnstrInfo=i, cnstrFromPreds=ps})- = r {cnstrPred=varUpd s p, cnstrInfo=varUpd s i, cnstrFromPreds=map (varUpd s) ps}--{-# LINE 120 "src/ehc/CHR/Constraint.chs" #-}--- | The trace of an unresolved predicate-data UnresolvedTrace p info- = UnresolvedTrace_None -- no trace required when all is resolved- | UnresolvedTrace_Red -- ok reduction, with failure deeper down- { utraceRedFrom :: p- , utraceInfoTo2From :: info- , utraceRedTo :: [UnresolvedTrace p info]- }- | UnresolvedTrace_Fail -- failed reduction- { utraceRedFrom :: p- -- , utraceInfoTo2From :: info- , utraceRedTo :: [UnresolvedTrace p info]- }- | UnresolvedTrace_Overlap -- choice could not be made- { utraceRedFrom :: p- , utraceRedChoices :: [(info,[UnresolvedTrace p info])]- }- deriving Show--instance Eq p => Eq (UnresolvedTrace p info) where- t1 == t2 = True -- utraceRedFrom t1 == utraceRedFrom t2--instance (PP p, PP info) => PP (UnresolvedTrace p info) where- pp x = case x of- UnresolvedTrace_None -> PP.empty- UnresolvedTrace_Red p i us -> p >|< ":" >#< i >-< indent 2 (vlist $ map pp us)- UnresolvedTrace_Fail p us -> p >|< ": FAIL" >-< indent 2 (vlist $ map pp us)- UnresolvedTrace_Overlap p uss -> p >|< ": OVERLAP" >-< indent 2 (vlist $ map (\(i,u) -> i >-< indent 2 (vlist $ map pp u)) uss)--{-# LINE 155 "src/ehc/CHR/Constraint.chs" #-}--- | Map from constraint to something-type ConstraintMp' p info x = Map.Map (Constraint p info) [x]--{-# LINE 160 "src/ehc/CHR/Constraint.chs" #-}-cnstrMpSingletonL :: Constraint p i -> [x] -> ConstraintMp' p i x-cnstrMpSingletonL c xs = Map.singleton c xs--cnstrMpSingleton :: Constraint p i -> x -> ConstraintMp' p i x-cnstrMpSingleton c x = cnstrMpSingletonL c [x]--cnstrMpFromList :: (Ord p, Ord i) => [(Constraint p i,x)] -> ConstraintMp' p i x-cnstrMpFromList l = Map.fromListWith (++) [ (c,[x]) | (c,x) <- l ]--cnstrMpMap :: (Ord p, Ord i) => (x -> y) -> ConstraintMp' p i x -> ConstraintMp' p i y-cnstrMpMap f = Map.map (map f)--{-# LINE 174 "src/ehc/CHR/Constraint.chs" #-}--- | Map from constraint to info + trace-type ConstraintToInfoTraceMp p info = ConstraintMp' p info (info,[UnresolvedTrace p info])--{-# LINE 179 "src/ehc/CHR/Constraint.chs" #-}-cnstrTraceMpFromList :: (Ord p, Ord i) => [(Constraint p i,(i,[UnresolvedTrace p i]))] -> ConstraintToInfoTraceMp p i-cnstrTraceMpFromList = cnstrMpFromList--cnstrTraceMpSingleton :: Constraint p i -> i -> [UnresolvedTrace p i] -> ConstraintToInfoTraceMp p i-cnstrTraceMpSingleton c i ts = cnstrMpSingleton c (i,ts)--cnstrTraceMpElimTrace :: (Ord p, Ord i) => ConstraintToInfoTraceMp p i -> ConstraintToInfoMap p i-cnstrTraceMpElimTrace = cnstrMpMap fst--cnstrTraceMpLiftTrace :: (Ord p, Ord i) => ConstraintToInfoMap p i -> ConstraintToInfoTraceMp p i-cnstrTraceMpLiftTrace = cnstrMpMap (\x -> (x,[]))--{-# LINE 193 "src/ehc/CHR/Constraint.chs" #-}--- | Map from constraint to info-type ConstraintToInfoMap p info = ConstraintMp' p info info--{-# LINE 198 "src/ehc/CHR/Constraint.chs" #-}-emptyCnstrMp :: ConstraintMp' p info x-emptyCnstrMp = Map.empty--{-# LINE 208 "src/ehc/CHR/Constraint.chs" #-}-cnstrMpUnion :: (Ord p, Ord i) => ConstraintMp' p i x -> ConstraintMp' p i x -> ConstraintMp' p i x-cnstrMpUnion = Map.unionWith (++)--cnstrMpUnions :: (Ord p, Ord i) => [ConstraintMp' p i x] -> ConstraintMp' p i x-cnstrMpUnions = Map.unionsWith (++)--{-# LINE 220 "src/ehc/CHR/Constraint.chs" #-}--- | Predicate for whether solving is required-cnstrRequiresSolve :: Constraint p info -> Bool-cnstrRequiresSolve (Reduction {}) = False-cnstrRequiresSolve _ = True--{-# LINE 231 "src/ehc/CHR/Constraint.chs" #-}-instance (PP p, PP info) => PP (Constraint p info) where- pp (Prove p ) = "Prove" >#< p- pp (Assume p ) = "Assume" >#< p- pp (Reduction {cnstrPred=p, cnstrInfo=i, cnstrFromPreds=ps})- = "Red" >#< p >#< "<" >#< i >#< "<" >#< ppBracketsCommas ps--{-# LINE 243 "src/ehc/CHR/Constraint.chs" #-}-instance (Serialize p, Serialize i) => Serialize (Constraint p i) where- sput (Prove a ) = sputWord8 0 >> sput a- sput (Assume a ) = sputWord8 1 >> sput a- sput (Reduction a b c d) = sputWord8 2 >> sput a >> sput b >> sput c >> sput d- sget = do t <- sgetWord8- case t of- 0 -> liftM Prove sget- 1 -> liftM Assume sget- 2 -> liftM4 Reduction sget sget sget sget-