summaryrefslogtreecommitdiff
path: root/tests/examples
diff options
context:
space:
mode:
Diffstat (limited to 'tests/examples')
-rw-r--r--tests/examples/AddHiding1.hs7
-rw-r--r--tests/examples/AddHiding1.hs.expected7
-rw-r--r--tests/examples/AddHiding2.hs5
-rw-r--r--tests/examples/AddHiding2.hs.expected5
-rw-r--r--tests/examples/AddLocalDecl4.hs3
-rw-r--r--tests/examples/AddLocalDecl4.hs.expected6
-rw-r--r--tests/examples/AddLocalDecl5.hs8
-rw-r--r--tests/examples/AddLocalDecl5.hs.expected9
-rw-r--r--tests/examples/AddLocalDecl6.hs9
-rw-r--r--tests/examples/AddLocalDecl6.hs.expected11
-rw-r--r--tests/examples/Base.hs26
-rw-r--r--tests/examples/CloneDecl1.hs10
-rw-r--r--tests/examples/CloneDecl1.hs.expected17
-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/Rename2.hs4
-rw-r--r--tests/examples/Rename2.hs.expected4
-rw-r--r--tests/examples/RmDecl3.hs1
-rw-r--r--tests/examples/RmDecl3.hs.expected1
-rw-r--r--tests/examples/RmDecl4.hs9
-rw-r--r--tests/examples/RmDecl4.hs.expected10
-rw-r--r--tests/examples/RmDecl5.hs6
-rw-r--r--tests/examples/RmDecl5.hs.expected4
-rw-r--r--tests/examples/RmDecl6.hs11
-rw-r--r--tests/examples/RmDecl6.hs.expected8
-rw-r--r--tests/examples/RmDecl7.hs8
-rw-r--r--tests/examples/RmDecl7.hs.expected6
-rw-r--r--tests/examples/RmTypeSig2.hs7
-rw-r--r--tests/examples/RmTypeSig2.hs.expected6
-rw-r--r--tests/examples/SegFault.hs133
-rw-r--r--tests/examples/SegFault2.hs202
-rw-r--r--tests/examples/SimpleDo.hs4
-rw-r--r--tests/examples/TypeSignature.hs12
36 files changed, 684 insertions, 0 deletions
diff --git a/tests/examples/AddHiding1.hs b/tests/examples/AddHiding1.hs
new file mode 100644
index 0000000..698983e
--- /dev/null
+++ b/tests/examples/AddHiding1.hs
@@ -0,0 +1,7 @@
+module AddHiding1 where
+
+import Data.Maybe
+
+import Data.Maybe hiding (n1,n2)
+
+f = 1
diff --git a/tests/examples/AddHiding1.hs.expected b/tests/examples/AddHiding1.hs.expected
new file mode 100644
index 0000000..2e29096
--- /dev/null
+++ b/tests/examples/AddHiding1.hs.expected
@@ -0,0 +1,7 @@
+module AddHiding1 where
+
+import Data.Maybe hiding (n1,n2)
+
+import Data.Maybe hiding (n1,n2)
+
+f = 1
diff --git a/tests/examples/AddHiding2.hs b/tests/examples/AddHiding2.hs
new file mode 100644
index 0000000..f5f551a
--- /dev/null
+++ b/tests/examples/AddHiding2.hs
@@ -0,0 +1,5 @@
+module AddHiding2 where
+
+import Data.Maybe hiding (f1,f2)
+
+f = 1
diff --git a/tests/examples/AddHiding2.hs.expected b/tests/examples/AddHiding2.hs.expected
new file mode 100644
index 0000000..d620052
--- /dev/null
+++ b/tests/examples/AddHiding2.hs.expected
@@ -0,0 +1,5 @@
+module AddHiding2 where
+
+import Data.Maybe hiding (f1,f2,n1,n2)
+
+f = 1
diff --git a/tests/examples/AddLocalDecl4.hs b/tests/examples/AddLocalDecl4.hs
new file mode 100644
index 0000000..2ec2c0b
--- /dev/null
+++ b/tests/examples/AddLocalDecl4.hs
@@ -0,0 +1,3 @@
+module AddLocalDecl4 where
+
+toplevel x = c * x
diff --git a/tests/examples/AddLocalDecl4.hs.expected b/tests/examples/AddLocalDecl4.hs.expected
new file mode 100644
index 0000000..b3c1445
--- /dev/null
+++ b/tests/examples/AddLocalDecl4.hs.expected
@@ -0,0 +1,6 @@
+module AddLocalDecl4 where
+
+toplevel x = c * x
+ where
+ nn :: Int
+ nn = 2
diff --git a/tests/examples/AddLocalDecl5.hs b/tests/examples/AddLocalDecl5.hs
new file mode 100644
index 0000000..9f07e10
--- /dev/null
+++ b/tests/examples/AddLocalDecl5.hs
@@ -0,0 +1,8 @@
+module AddLocalDecl5 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+
+-- c,d :: Integer
+c = 7
+d = 9
diff --git a/tests/examples/AddLocalDecl5.hs.expected b/tests/examples/AddLocalDecl5.hs.expected
new file mode 100644
index 0000000..5e66dc5
--- /dev/null
+++ b/tests/examples/AddLocalDecl5.hs.expected
@@ -0,0 +1,9 @@
+module AddLocalDecl5 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+ where
+ -- c,d :: Integer
+ c = 7
+
+d = 9
diff --git a/tests/examples/AddLocalDecl6.hs b/tests/examples/AddLocalDecl6.hs
new file mode 100644
index 0000000..2ab96af
--- /dev/null
+++ b/tests/examples/AddLocalDecl6.hs
@@ -0,0 +1,9 @@
+module AddLocalDecl6 where
+
+foo [] = 1 -- comment 0
+foo xs = 2 -- comment 1
+
+bar [] = 1 -- comment 2
+ where
+ x = 3
+bar xs = 2 -- comment 3
diff --git a/tests/examples/AddLocalDecl6.hs.expected b/tests/examples/AddLocalDecl6.hs.expected
new file mode 100644
index 0000000..b689feb
--- /dev/null
+++ b/tests/examples/AddLocalDecl6.hs.expected
@@ -0,0 +1,11 @@
+module AddLocalDecl6 where
+
+foo [] = 1 -- comment 0
+ where
+ x = 3
+foo xs = 2 -- comment 1
+
+bar [] = 1 -- comment 2
+ where
+ x = 3
+bar xs = 2 -- comment 3
diff --git a/tests/examples/Base.hs b/tests/examples/Base.hs
new file mode 100644
index 0000000..9fd44f4
--- /dev/null
+++ b/tests/examples/Base.hs
@@ -0,0 +1,26 @@
+{-# 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/CloneDecl1.hs b/tests/examples/CloneDecl1.hs
new file mode 100644
index 0000000..387eeee
--- /dev/null
+++ b/tests/examples/CloneDecl1.hs
@@ -0,0 +1,10 @@
+module CloneDecl1 where
+
+z = 3
+
+foo a b =
+ let
+ x = a + b + z
+ y = a * b - z
+ in
+ x + y
diff --git a/tests/examples/CloneDecl1.hs.expected b/tests/examples/CloneDecl1.hs.expected
new file mode 100644
index 0000000..7d020f9
--- /dev/null
+++ b/tests/examples/CloneDecl1.hs.expected
@@ -0,0 +1,17 @@
+module CloneDecl1 where
+
+z = 3
+
+foo a b =
+ let
+ x = a + b + z
+ y = a * b - z
+ in
+ x + y
+
+foo a b =
+ let
+ x = a + b + z
+ y = a * b - z
+ in
+ x + y
diff --git a/tests/examples/Error.hs b/tests/examples/Error.hs
new file mode 100644
index 0000000..72aa444
--- /dev/null
+++ b/tests/examples/Error.hs
@@ -0,0 +1,110 @@
+
+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
new file mode 100644
index 0000000..5a73cea
--- /dev/null
+++ b/tests/examples/Join.hs
@@ -0,0 +1,7 @@
+
+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
new file mode 100644
index 0000000..03481a3
--- /dev/null
+++ b/tests/examples/Lambda.hs
@@ -0,0 +1,2 @@
+
+i = \x -> x
diff --git a/tests/examples/NormaliseLayout.hs b/tests/examples/NormaliseLayout.hs
new file mode 100644
index 0000000..3d07966
--- /dev/null
+++ b/tests/examples/NormaliseLayout.hs
@@ -0,0 +1,5 @@
+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
new file mode 100644
index 0000000..6ca9a1f
--- /dev/null
+++ b/tests/examples/NormaliseLayout.hs.expected
@@ -0,0 +1 @@
+module Main where
diff --git a/tests/examples/Rename2.hs b/tests/examples/Rename2.hs
new file mode 100644
index 0000000..29fea06
--- /dev/null
+++ b/tests/examples/Rename2.hs
@@ -0,0 +1,4 @@
+
+foo' x = case (odd x) of
+ True -> "Odd"
+ False -> "Even"
diff --git a/tests/examples/Rename2.hs.expected b/tests/examples/Rename2.hs.expected
new file mode 100644
index 0000000..6be3ff6
--- /dev/null
+++ b/tests/examples/Rename2.hs.expected
@@ -0,0 +1,4 @@
+
+joe x = case (odd x) of
+ True -> "Odd"
+ False -> "Even"
diff --git a/tests/examples/RmDecl3.hs b/tests/examples/RmDecl3.hs
index ed42216..280bccf 100644
--- a/tests/examples/RmDecl3.hs
+++ b/tests/examples/RmDecl3.hs
@@ -5,4 +5,5 @@ ff y = y + zz
where
zz = 1
+foo = 3
-- EOF
diff --git a/tests/examples/RmDecl3.hs.expected b/tests/examples/RmDecl3.hs.expected
index 023c9b9..ca14f33 100644
--- a/tests/examples/RmDecl3.hs.expected
+++ b/tests/examples/RmDecl3.hs.expected
@@ -5,4 +5,5 @@ ff y = y + zz
zz = 1
+foo = 3
-- EOF
diff --git a/tests/examples/RmDecl4.hs b/tests/examples/RmDecl4.hs
new file mode 100644
index 0000000..532b738
--- /dev/null
+++ b/tests/examples/RmDecl4.hs
@@ -0,0 +1,9 @@
+module RmDecl4 where
+
+-- Remove first declaration from a where clause, last should still be indented
+ff y = y + zz + xx
+ where
+ zz = 1
+ xx = 2
+
+-- EOF
diff --git a/tests/examples/RmDecl4.hs.expected b/tests/examples/RmDecl4.hs.expected
new file mode 100644
index 0000000..e7c71db
--- /dev/null
+++ b/tests/examples/RmDecl4.hs.expected
@@ -0,0 +1,10 @@
+module RmDecl4 where
+
+-- Remove first declaration from a where clause, last should still be indented
+ff y = y + zz + xx
+ where
+ xx = 2
+
+zz = 1
+
+-- EOF
diff --git a/tests/examples/RmDecl5.hs b/tests/examples/RmDecl5.hs
new file mode 100644
index 0000000..e5dbaed
--- /dev/null
+++ b/tests/examples/RmDecl5.hs
@@ -0,0 +1,6 @@
+module RmDecl5 where
+
+sumSquares x y = let sq 0=0
+ sq z=z^pow
+ pow=2
+ in sq x + sq y
diff --git a/tests/examples/RmDecl5.hs.expected b/tests/examples/RmDecl5.hs.expected
new file mode 100644
index 0000000..9c3c6fe
--- /dev/null
+++ b/tests/examples/RmDecl5.hs.expected
@@ -0,0 +1,4 @@
+module RmDecl5 where
+
+sumSquares x y = let pow=2
+ in sq x + sq y
diff --git a/tests/examples/RmDecl6.hs b/tests/examples/RmDecl6.hs
new file mode 100644
index 0000000..f902880
--- /dev/null
+++ b/tests/examples/RmDecl6.hs
@@ -0,0 +1,11 @@
+module RmDecl6 where
+
+foo a = baz
+ where
+ baz :: Int
+ baz = x + a
+
+ x = 1
+
+ y :: Int -> Int -> Int
+ y a b = undefined
diff --git a/tests/examples/RmDecl6.hs.expected b/tests/examples/RmDecl6.hs.expected
new file mode 100644
index 0000000..e019cb8
--- /dev/null
+++ b/tests/examples/RmDecl6.hs.expected
@@ -0,0 +1,8 @@
+module RmDecl6 where
+
+foo a = baz
+ where
+ x = 1
+
+ y :: Int -> Int -> Int
+ y a b = undefined
diff --git a/tests/examples/RmDecl7.hs b/tests/examples/RmDecl7.hs
new file mode 100644
index 0000000..c6c09e1
--- /dev/null
+++ b/tests/examples/RmDecl7.hs
@@ -0,0 +1,8 @@
+module RmDecl7 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+
+-- c,d :: Integer
+c = 7
+d = 9
diff --git a/tests/examples/RmDecl7.hs.expected b/tests/examples/RmDecl7.hs.expected
new file mode 100644
index 0000000..daf8438
--- /dev/null
+++ b/tests/examples/RmDecl7.hs.expected
@@ -0,0 +1,6 @@
+module RmDecl7 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+
+d = 9
diff --git a/tests/examples/RmTypeSig2.hs b/tests/examples/RmTypeSig2.hs
new file mode 100644
index 0000000..4dffd8d
--- /dev/null
+++ b/tests/examples/RmTypeSig2.hs
@@ -0,0 +1,7 @@
+module RmTypeSig2 where
+
+-- Pattern bind
+tup@(h,t) = (1,ff)
+ where
+ ff :: Int
+ ff = 15
diff --git a/tests/examples/RmTypeSig2.hs.expected b/tests/examples/RmTypeSig2.hs.expected
new file mode 100644
index 0000000..b83f304
--- /dev/null
+++ b/tests/examples/RmTypeSig2.hs.expected
@@ -0,0 +1,6 @@
+module RmTypeSig2 where
+
+-- Pattern bind
+tup@(h,t) = (1,ff)
+ where
+ ff = 15
diff --git a/tests/examples/SegFault.hs b/tests/examples/SegFault.hs
new file mode 100644
index 0000000..cf5e810
--- /dev/null
+++ b/tests/examples/SegFault.hs
@@ -0,0 +1,133 @@
+{-# 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
new file mode 100644
index 0000000..138e055
--- /dev/null
+++ b/tests/examples/SegFault2.hs
@@ -0,0 +1,202 @@
+{-# 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
+
diff --git a/tests/examples/SimpleDo.hs b/tests/examples/SimpleDo.hs
new file mode 100644
index 0000000..b9ec142
--- /dev/null
+++ b/tests/examples/SimpleDo.hs
@@ -0,0 +1,4 @@
+
+foo = do
+ let x = 1 -- a comment
+ return x
diff --git a/tests/examples/TypeSignature.hs b/tests/examples/TypeSignature.hs
new file mode 100644
index 0000000..cb52d66
--- /dev/null
+++ b/tests/examples/TypeSignature.hs
@@ -0,0 +1,12 @@
+module TypeSignature where
+
+{- Lifting baz to the top level should bring in xx and a as parameters,
+ and update the signature to include these
+-}
+foo a = (baz xx a)
+ where
+ xx :: Int -> Int -> Int
+ xx p1 p2 = p1 + p2
+
+baz :: (Int -> Int -> Int) -> Int ->Int
+baz xx a = xx 1 a