Commit 216bfb01 authored by partain's avatar partain

[project @ 1996-07-26 20:58:52 by partain]

Final changes for 2.01
parent 5eb1c77c
......@@ -55,8 +55,8 @@
(modify-syntax-entry ?\f "> b" haskell-mode-syntax-table)
(modify-syntax-entry ?\n "> b" haskell-mode-syntax-table)
(modify-syntax-entry ?\" "\"" haskell-mode-syntax-table)
(modify-syntax-entry ?\' "_" haskell-mode-syntax-table)
(modify-syntax-entry ?_ "_" haskell-mode-syntax-table)
(modify-syntax-entry ?\' "w" haskell-mode-syntax-table)
(modify-syntax-entry ?_ "w" haskell-mode-syntax-table)
(modify-syntax-entry ?\\ "." haskell-mode-syntax-table)
(modify-syntax-entry ?\( "()" haskell-mode-syntax-table)
(modify-syntax-entry ?\) ")(" haskell-mode-syntax-table)
......@@ -81,8 +81,6 @@
(setq comment-column 40)
(make-local-variable 'comment-indent-function)
(setq comment-indent-function 'haskell-comment-indent)
;(make-local-variable 'font-lock-keywords)
;(setq font-lock-keywords haskell-literate-font-lock-keywords)
)
(defun haskell-mode ()
......@@ -106,6 +104,8 @@ M-TAB toggles the state of the bird track on the current-line.
Entry to this mode calls haskell-mode-hook and haskell-literate-mode-hook."
(interactive)
(haskell-vars)
(make-local-variable 'font-lock-keywords)
(setq font-lock-keywords haskell-literate-font-lock-keywords)
(setq major-mode 'haskell-literate-mode)
(setq mode-name "Literate Haskell")
(use-local-map haskell-literate-mode-map)
......@@ -190,12 +190,13 @@ Entry to this mode calls haskell-mode-hook and haskell-literate-mode-hook."
(list
'("^[^>\n].*$" . font-lock-comment-face)
(concat "\\b\\("
(mapconcat 'identity
'("case" "class" "data" "default" "deriving" "else" "hiding"
"if" "import" "in" "infix" "infixl" "infixr" "instance"
"interface" "let" "module" "of" "renaming" "then" "to"
"type" "where")
"\\|")
"\\)\\b")
(mapconcat 'identity
'("case" "class" "data" "default" "deriving" "else"
"hiding" "if" "import" "in" "infix" "infixl"
"infixr" "instance" "interface" "let" "module"
"of" "renaming" "then" "to" "type" "where")
"\\|")
"\\)\\b")
; '("(\\|)\\|\\[\\|\\]\\|,\\|[\\\\!$#^%&*@~?=-+<>.:]+" . font-lock-function-name-face)
))
......@@ -25,11 +25,12 @@ import DsUtils
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
import FieldLabel ( allFieldLabelTags, fieldLabelTag )
import Id ( idType, mkTupleCon,
import FieldLabel ( FieldLabel {- Eq instance -} )
import Id ( idType, mkTupleCon, dataConFieldLabels,
dataConArgTys, recordSelectorFieldLabel,
GenId{-instance-}
)
import Name ( Name {--O only-} )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
import PrelVals ( pAT_ERROR_ID )
......@@ -337,12 +338,12 @@ tidy1 v (RecPat con_id pat_ty rpats) match_result
-- Boring stuff to find the arg-tys of the constructor
(_, inst_tys, _) = {-trace "Match.getAppDataTyConExpandingDicts" $-} getAppDataTyConExpandingDicts pat_ty
con_arg_tys' = dataConArgTys con_id inst_tys
tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags
tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels con_id)
-- mk_pat picks a WildPat of the appropriate type for absent fields,
-- and the specified pattern for present fields
mk_pat (arg_ty, tag) = case [pat | (sel_id,pat,_) <- rpats,
fieldLabelTag (recordSelectorFieldLabel sel_id) == tag
mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats,
recordSelectorFieldLabel sel_id == lbl
] of
(pat:pats) -> ASSERT( null pats )
pat
......
......@@ -7,5 +7,4 @@ SUBDIRS = reader \
deSugar \
printing \
ccall \
deriving \
bugs
deriving
......@@ -2,7 +2,7 @@
module Test where
import PreludeGlaIO
import PreludeGlaST
-- simple functions
......
......@@ -2,20 +2,20 @@
module Test where
import PreludeGlaIO
import PreludeGlaST
-- Test returning results
a :: PrimIO _MallocPtr
a :: PrimIO ForeignObj
a = _ccall_ a
b :: PrimIO _StablePtr
b :: PrimIO StablePtr
b = _ccall_ b
-- Test taking arguments
c :: _MallocPtr -> PrimIO Int
c :: ForeignObj -> PrimIO Int
c x = _ccall_ c x
d :: _StablePtr -> PrimIO Int
d :: StablePtr -> PrimIO Int
d x = _ccall_ d x
--!!! cc003 -- ccall with unresolved polymorphism (should fail)
module Test where
import PreludeGlaIO
import PreludeGlaST
fubar :: PrimIO Int
fubar = ccall f `seqPrimIO` ccall b
......
--!!! cc004 -- ccall with synonyms, polymorphic type variables and user type variables.
module Test where
import PreludeGlaIO
import PreludeGlaST
-- Since I messed up the handling of polymorphism originally, I'll
-- explicitly test code with UserSysTyVar (ie an explicit polymorphic
......
......@@ -3,6 +3,9 @@
-- do all the right types get stuck on all the
-- Nils and Conses?
module ShouldSucceed where
f x = [[], []]
g x = ([], [], [])
--!!! ds026 -- classes -- incl. polymorphic method
module ShouldSucceed where
class Foo a where
op :: a -> a
......
--!!! ds028: failable pats in top row
module ShouldSucceed where
-- when the first row of pats doesn't have convenient
-- variables to grab...
......
module ShouldSucceed where
foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
foldPair fg ab [] = ab
foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
......
--!!! recursive funs tangled in an AbsBind
module ShouldSucceed where
flatten :: Int -- Indentation
-> Bool -- True => just had a newline
-> Float -- Current seq to flatten
......
--!!! AbsBinds with tyvars, no dictvars, but some dict binds
--
module ShouldSucceed where
f x y = (fst (g y x), x+(1::Int))
g x y = (fst (f x y), y+(1::Int))
--!!! make sure correct type applications get put in
--!!! when (:) is saturated.
module ShouldSucceed where
f = (:)
--!!! canonical weird example for "deriving"
module ShouldSucceed where
data X a b
= C1 (T a)
| C2 (Y b)
| C3 (X b a)
deriving Text
deriving (Read, Show)
data Y b
= D1
| D2 (X Int b)
deriving Text
deriving (Read, Show)
data T a
= E1
instance Eq a => Text (T a) where
instance Eq a => Show (T a) where
showsPrec = error "show"
instance Eq a => Read (T a) where
readsPrec = error "read"
module ShouldSucceed where
data Z a b
= C1 (T a)
| C2 (Z [a] [b])
deriving Text
deriving (Show, Read)
data T a
= E1
instance Eq a => Text (T a) where
instance Eq a => Show (T a) where
showsPrec = error "show"
instance Eq a => Read (T a) where
readsPrec = error "read"
--!!! This is the example given in TcDeriv
--
module ShouldSucceed where
data T a b
= C1 (Foo a) (Bar b)
| C2 Int (T b a)
......
--!!! simple example of deriving Ord (and, implicitly, Eq)
--
module ShouldSucceed where
data Foo a b
= C1 a Int
| C2 b Double
......
--!!! simple example of deriving Enum
--
module ShouldSucceed where
data Foo = Foo1 | Foo2 | Foo3 | Foo4 | Foo5 | Foo6 | Foo7 | Foo8
deriving Enum
--!!! simple examples of deriving Ix
--
module ShouldSucceed where
import Ix
data Foo = Foo1 | Foo2 | Foo3 | Foo4 | Foo5 | Foo6 | Foo7 | Foo8
deriving Ix
......
--!!! buggy deriving with function type, reported by Sigbjorn Finne
module ShouldSucceed where
data Foo = Foo (Int -> Int) deriving Eq
......@@ -7,7 +7,7 @@ runtests::
@echo '# Validation tests for the renamer (incl dependency analysis) #'
@echo '###############################################################'
TEST_FLAGS=/*-ddump-rn1 -ddump-rn2 -ddump-rn3*/ -ddump-rn4
TEST_FLAGS=/*-ddump-rn1 -ddump-rn2 -ddump-rn3*/ -ddump-rn
RunStdTest(rn001,$(GHC), -noC $(TEST_FLAGS) rn001.hs -o2 rn001.stderr -x1)
RunStdTest(rn002,$(GHC), -noC $(TEST_FLAGS) rn002.hs -o2 rn002.stderr -x1)
......
......@@ -3,5 +3,4 @@
SUBDIRS = /* TEMPORARILY OUT: check_mess */ \
should_fail \
/* TEMPORARILY OUT: test_exps */ \
should_succeed \
bugs
should_succeed
--!!! tests for InstOpErr
module ShouldFail where
data Foo = Bar | Baz
......
module ShouldFail where
f x = if 'a' then 1 else 2
-- from Jon Hill
module ShouldFail where
buglet = [ x | (x,y) <- buglet ]
......@@ -10,6 +10,8 @@ I came across a rather nasty error message when I gave a function an
incorrect type signature (the context is wrong). I can remember reading
in the source about this problem - I just thought I'd let you know anyway :-)
-}
module ShouldSucceed where
test::(Num a, Eq a) => a -> Bool
test x = (x `mod` 3) == 0
......
......@@ -6,4 +6,4 @@ data NUM = ONE | TWO
instance Num NUM
instance Num NUM
instance Eq NUM
instance Text NUM
instance Show NUM
......@@ -42,6 +42,7 @@ all right.
-- Lennart
- ------- End of forwarded message -------
-}
module ShouldFail where
sort :: Ord a => [a] -> [a]
sort xs = s xs (length xs)
......
......@@ -10,7 +10,7 @@ instance Num a => Foo [a] where
foo (x:xs) = map (x+) xs
instance (Eq a, Text a) => Bar [a] where
instance (Eq a, Show a) => Bar [a] where
bar [] = []
bar (x:xs) = foo xs where u = x==x
v = show x
......@@ -20,7 +20,7 @@ instance (Eq a, Text a) => Bar [a] where
{-
class Foo a => Bar2 a where bar2 :: a -> a
instance (Eq a, Text a) => Foo [a]
instance (Eq a, Show a) => Foo [a]
instance Num a => Bar2 [a]
......
......@@ -19,4 +19,4 @@ ss = sin * sin
cc = cos * cos
tt = ss + cc
main _ = [AppendChan stdout ((show (tt 0.4))++ " "++(show (tt 1.652)))]
main = putStr ((show (tt 0.4))++ " "++(show (tt 1.652)))
--!!! a bad _CCallable thing (from a bug from Satnam)
--
data Socket = Socket# _Addr
instance _CCallable Socket
module ShouldSucceed where
import PreludeGlaST
data Socket = Socket# Addr
instance CCallable Socket
f :: Socket -> PrimIO ()
f x = _ccall_ foo x
--!! function types in deriving Eq things
-- From a bug report by Dave Harrison <D.A.Harrison@newcastle.ac.uk>
module Simulation(Process(..),
module Simulation(Process,
Status,
Pid(..),
Time(..),
Pid,
Time,
Continuation,
Message,
MessList(..) ) where
MessList ) where
type Process a = Pid -> Time -> Message a -> ( MessList a,
Continuation a)
......
module ShouldFail where
class (B a) => C a where
op1 :: a -> a
module ShouldFail where
instance B Bool where
op1 a = a
module ShouldFail where
f x = (x + 1 :: Int) :: Float
module ShouldFail where
data Foo = MkFoo Bool
......
module ShouldFail where
import Array
--!!! inadvertently using => instead of ->
......
--!! signature bugs exposed by Sigbjorne Finne
--
module ShouldFail where
type Flarp a = (b,b)
......
......@@ -8,10 +8,10 @@ type Module = (String,[Declaration])
data Declaration
= Architecture String StructuralExpression |
Behaviour String Parameter Parameter BehaviouralExpression
deriving (Eq, Text)
deriving (Eq, Show)
data Parameter = ParameterVariable String | ParameterList [Parameter]
deriving (Eq, Text)
deriving (Eq, Show)
nameOfModule :: Module -> String
nameOfModule (name, _) = name
......@@ -20,14 +20,14 @@ data StructuralExpression
= Variable String |
Serial StructuralExpression StructuralExpression |
Par [StructuralExpression]
deriving (Eq, Text)
deriving (Eq, Show)
data BehaviouralExpression
= BehaviouralVariable String
| AndExpr BehaviouralExpression BehaviouralExpression
| OrExpr BehaviouralExpression BehaviouralExpression
| NotExpr BehaviouralExpression
deriving (Eq, Text)
deriving (Eq, Show)
type BehaviouralRelation
......
......@@ -5,6 +5,7 @@ From: Julian Seward (DRL PhD) <sewardj@computer-science.manchester.ac.uk>
Message-Id: <9412081138.AA16652@rdf009.cs.man.ac.uk>
To: partain@dcs.gla.ac.uk
-}
module ShouldFail where
type IMonad a
= IMonadState -> IMonadReturn a
......
......@@ -14,11 +14,11 @@ subRangeValue (SubRange (lower, upper) value) = value
subRange :: SubRange a -> (a, a)
subRange (SubRange r value) = r
newRange :: (Ord a, Text a) => (a, a) -> a -> SubRange a
newRange :: (Ord a, Show a) => (a, a) -> a -> SubRange a
newRange r value = checkRange (SubRange r value)
checkRange :: (Ord a, Text a) => SubRange a -> SubRange a
checkRange :: (Ord a, Show a) => SubRange a -> SubRange a
checkRange (SubRange (lower, upper) value)
= if (value < lower) || (value > upper) then
error ("### sub range error. range = " ++ show lower ++
......@@ -39,18 +39,18 @@ instance (Ord a) => Ord (SubRange a) where
relOp :: Ord a => (a->a->Bool) -> SubRange a -> SubRange a -> Bool
relOp op a b = (subRangeValue a) `op` (subRangeValue b)
rangeOf :: (Ord a, Text a) => SubRange a -> SubRange a -> SubRange a
rangeOf :: (Ord a, Show a) => SubRange a -> SubRange a -> SubRange a
rangeOf a b = checkRange (SubRange (subRange b) (subRangeValue a))
showRange :: Text a => SubRange a -> String
showRange :: Show a => SubRange a -> String
showRange (SubRange (lower, upper) value)
= show value ++ " :" ++ show lower ++ ".." ++ show upper
showRangePair :: (Text a, Text b) => (SubRange a, SubRange b) -> String
showRangePair :: (Show a, Show b) => (SubRange a, SubRange b) -> String
showRangePair (a, b)
= "(" ++ showRange a ++ ", " ++ showRange b ++ ")"
showRangeTriple :: (Text a, Text b, Text c) =>
showRangeTriple :: (Show a, Show b, Show c) =>
(SubRange a, SubRange b, SubRange c) -> String
showRangeTriple (a, b, c)
= "(" ++ showRange a ++ ", " ++ showRange b ++ ", " ++ showRange c ++ ")"
......
......@@ -6,22 +6,22 @@ module IndTree(IndTree(..), itgen, itiap, itrap, itrapstate) where
--partain: import Auxiliary
import PreludeGlaST
type IndTree s t = _MutableArray s (Int,Int) t
type IndTree s t = MutableArray s (Int,Int) t
itgen :: Constructed a => (Int,Int) -> a -> IndTree s a
itgen n x =
_runST (
runST (
newArray ((1,1),n) x)
itiap :: Constructed a => (Int,Int) -> (a->a) -> IndTree s a -> IndTree s a
itiap i f arr =
_runST (
runST (
readArray arr i `thenStrictlyST` \val ->
writeArray arr i (f val) `seqStrictlyST`
returnStrictlyST arr)
itrap :: Constructed a => ((Int,Int),(Int,Int)) -> (a->a) -> IndTree s a -> IndTree s a
itrap ((i,k),(j,l)) f arr = _runST(itrap' i k)
itrap ((i,k),(j,l)) f arr = runST(itrap' i k)
where
itrap' i k = if k > l then returnStrictlyST arr