summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlanZimmerman <>2015-11-15 11:47:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-11-15 11:47:00 (GMT)
commit306934b50ead38aad01a867c1364576f50d7be18 (patch)
treebd197b1f9bac39764a065a0a27bdb1852630b913
parent5ecab007e7289022da08fcedf63ccedf69c22d0b (diff)
version 0.4.2.00.4.2.0
-rw-r--r--ChangeLog3
-rw-r--r--ghc-exactprint.cabal2
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Annotate.hs28
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Delta.hs2
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Lookup.hs2
-rw-r--r--tests/Test.hs2
-rw-r--r--tests/examples/AddLocalDecl7.hs9
-rw-r--r--tests/examples/AddLocalDecl7.hs.expected11
-rw-r--r--tests/examples/Arrow2.hs53
-rw-r--r--tests/examples/Base.hs26
-rw-r--r--tests/examples/Error.hs110
-rw-r--r--tests/examples/Join.hs7
-rw-r--r--tests/examples/Lambda.hs2
-rw-r--r--tests/examples/NormaliseLayout.hs5
-rw-r--r--tests/examples/NormaliseLayout.hs.expected1
-rw-r--r--tests/examples/SegFault.hs133
-rw-r--r--tests/examples/SegFault2.hs202
17 files changed, 100 insertions, 498 deletions
diff --git a/ChangeLog b/ChangeLog
index 1bfeda6..cc2c8d3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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
diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal
index 00ec9cd..ec3717a 100644
--- a/ghc-exactprint.cabal
+++ b/ghc-exactprint.cabal
@@ -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
diff --git a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
index 0e92353..6ad572f 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
@@ -1902,15 +1902,21 @@ instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate n
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 n
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 "(|"
diff --git a/src/Language/Haskell/GHC/ExactPrint/Delta.hs b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
index 60e39b1..6900122 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Delta.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
@@ -494,7 +494,7 @@ checkUnicode gkw@(G kw) ss =
, GHC.Annlarrowtail
, GHC.Annrarrowtail
, GHC.AnnLarrowtail
- , GHC.AnnLarrowtail]
+ , GHC.AnnRarrowtail]
checkUnicode kwid _ = kwid
-- ---------------------------------------------------------------------
diff --git a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
index 14b21f5..6a7117b 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
@@ -96,7 +96,7 @@ keywordToString kw =
(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 ) -> "'"
diff --git a/tests/Test.hs b/tests/Test.hs
index 677153e..0c9d0d8 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -58,6 +58,7 @@ tests = TestList $
, 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 @@ tt' = formatTT =<< partition snd <$> sequence [ return ("", True)
-- , 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"
diff --git a/tests/examples/AddLocalDecl7.hs b/tests/examples/AddLocalDecl7.hs
new file mode 100644
index 0000000..115b0c3
--- /dev/null
+++ b/tests/examples/AddLocalDecl7.hs
@@ -0,0 +1,9 @@
+module AddLocalDecl7 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+
+-- c,d :: Integer
+c = 7
+d = 9
+
diff --git a/tests/examples/AddLocalDecl7.hs.expected b/tests/examples/AddLocalDecl7.hs.expected
new file mode 100644
index 0000000..e5fc88e
--- /dev/null
+++ b/tests/examples/AddLocalDecl7.hs.expected
@@ -0,0 +1,11 @@
+module AddLocalDecl7 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+ where
+ nn = nn2
+
+-- c,d :: Integer
+c = 7
+d = 9
+
diff --git a/tests/examples/Arrow2.hs b/tests/examples/Arrow2.hs
new file mode 100644
index 0000000..b6e7170
--- /dev/null
+++ b/tests/examples/Arrow2.hs
@@ -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
diff --git a/tests/examples/Base.hs b/tests/examples/Base.hs
deleted file mode 100644
index 9fd44f4..0000000
--- a/tests/examples/Base.hs
+++ /dev/null
@@ -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)
diff --git a/tests/examples/Error.hs b/tests/examples/Error.hs
deleted file mode 100644
index 72aa444..0000000
--- a/tests/examples/Error.hs
+++ /dev/null
@@ -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}
diff --git a/tests/examples/Join.hs b/tests/examples/Join.hs
deleted file mode 100644
index 5a73cea..0000000
--- a/tests/examples/Join.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-
-forkOS_entry :: StablePtr (IO ()) -> IO ()
-forkOS_entry stableAction = do
- action <- deRefStablePtr stableAction
- action
-
-
diff --git a/tests/examples/Lambda.hs b/tests/examples/Lambda.hs
deleted file mode 100644
index 03481a3..0000000
--- a/tests/examples/Lambda.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-
-i = \x -> x
diff --git a/tests/examples/NormaliseLayout.hs b/tests/examples/NormaliseLayout.hs
deleted file mode 100644
index 3d07966..0000000
--- a/tests/examples/NormaliseLayout.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Main where
-
-foo x = baz
- where foo = 2
- two = 4 where bax = 4
diff --git a/tests/examples/NormaliseLayout.hs.expected b/tests/examples/NormaliseLayout.hs.expected
deleted file mode 100644
index 6ca9a1f..0000000
--- a/tests/examples/NormaliseLayout.hs.expected
+++ /dev/null
@@ -1 +0,0 @@
-module Main where
diff --git a/tests/examples/SegFault.hs b/tests/examples/SegFault.hs
deleted file mode 100644
index cf5e810..0000000
--- a/tests/examples/SegFault.hs
+++ /dev/null
@@ -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" #-}
diff --git a/tests/examples/SegFault2.hs b/tests/examples/SegFault2.hs
deleted file mode 100644
index 138e055..0000000
--- a/tests/examples/SegFault2.hs
+++ /dev/null
@@ -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
-