Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

fix for nonreporting of identifier ref ambiguity, arising in JCU afte…

…r UHC changes to name structure; infrastructure was there but onl partially used...
  • Loading branch information...
commit c4e198f71c6dc269e53c864b4a1965a2e6b78066 1 parent 6f1216f
@atzedijkstra atzedijkstra authored
View
2  EHC/ehclib/base/Text/Read/Lex.hs
@@ -48,7 +48,7 @@ import GHC.Real( Ratio(..), Integral, Rational, (%), fromIntegral,
import GHC.List
import GHC.Enum( maxBound )
#else
-import Prelude hiding ( lex )
+import Prelude hiding ( lex, lexDigits, lexLitChar )
import Data.Char( chr, ord, isSpace, isAlpha, isAlphaNum )
import Data.Ratio( Ratio, (%) )
#endif
View
2  EHC/ehclib/uhcbase/System/Posix/Internals.hs
@@ -81,7 +81,7 @@ type CUtimbuf = ()
type CUtsname = ()
#ifndef __GLASGOW_HASKELL__
-type FD = CInt
+-- type FD = CInt
#endif
-- ---------------------------------------------------------------------------
View
6 EHC/src/ehc/Config.chs.in
@@ -68,7 +68,11 @@ version
%%[1 export(verInfo)
verInfo :: Version -> String
-verInfo v = verProg v ++ "-" ++ verFull v ++ ", Revision " ++ verSvnRevision v
+verInfo v =
+ verProg v ++ "-" ++ verFull v ++ ", revision " ++ verSvnRevision v
+%%[[50
+ ++ ", timestamp " ++ verTimestamp v
+%%]]
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
View
26 EHC/src/ehc/Gam.chs
@@ -159,6 +159,17 @@ type IdDefOccGam = Gam IdOcc IdDefOcc
type IdDefOccAsc = AssocL IdOcc [IdDefOcc]
%%]
+%%[1 export(idDefOccGamUnion)
+-- | Union gam, but tailored to maintaining duplicate definition info
+idDefOccGamUnion :: IdDefOccGam -> IdDefOccGam -> IdDefOccGam
+%%[[1
+idDefOccGamUnion = gamUnion
+%%][50
+idDefOccGamUnion = gamUnionWith idDefOccLCmb
+%%]]
+{-# INLINE idDefOccGamUnion #-}
+%%]
+
%%[9
idDefOccGamPartitionByKind :: [IdOccKind] -> IdDefOccGam -> (IdDefOccAsc,IdDefOccAsc)
idDefOccGamPartitionByKind ks
@@ -201,6 +212,7 @@ idGam2QualGam = gamMap (\(iocc,docc) -> (iocc {ioccNm = hsnQualified $ ioccNm io
idQualGamReplacement :: IdQualGam -> IdOccKind -> HsName -> HsName
idQualGamReplacement g k n = maybe n id $ gamLookup (IdOcc n k) g
+{-# INLINE idQualGamReplacement #-}
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -256,20 +268,6 @@ instance (Ord k, PP k, PP v) => PP (SGam k v) where
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% ForceEval
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[(9999 hmtyinfer || hmtyast)
-instance ForceEval TyKiKey
-%%[[102
- where
- fevCount (TyKiKey_Name n) = cm1 "TyKiKey_Name" `cmUnion` fevCount n
- fevCount (TyKiKey_TyVar v) = cm1 "TyKiKey_TyVar" `cmUnion` fevCount v
-%%]]
-
-%%]
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Init of soGam, only used by TyCore
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
View
6 EHC/src/ehc/Gam/Base.chs
@@ -284,6 +284,12 @@ gamFromAssocL = assocLToGam
{-# INLINE gamFromAssocL #-}
%%]
+%%[50 export(gamUnionWith)
+gamUnionWith :: Ord k => (v -> [v] -> [v]) -> Gam k v -> Gam k v -> Gam k v
+gamUnionWith cmb = sgamUnionWith (Just cmb)
+{-# INLINE gamUnionWith #-}
+%%]
+
%%[1
gamUnions :: Ord k => [Gam k v] -> Gam k v
gamUnions [] = emptyGam
View
25 EHC/src/ehc/Gam/ScopeMapGam.chs
@@ -104,40 +104,47 @@ instance Show (SGam k v) where
-- scope ident in scope?
inScp :: Scp -> Int -> Bool
inScp = flip elem
+{-# INLINE inScp #-}
-- sgam elt in scope?
sgameltInScp :: Scp -> SGamElt v -> Bool
sgameltInScp scp = inScp scp . sgeScpId
+{-# INLINE sgameltInScp #-}
%%]
%%[8
-- filter out the out of scopes
sgameltFilterInScp :: Scp -> [SGamElt v] -> [SGamElt v]
sgameltFilterInScp scp = filter (sgameltInScp scp)
+{-# INLINE sgameltFilterInScp #-}
-- map the in scopes
sgameltMapInScp :: Scp -> (v -> v) -> [SGamElt v] -> [SGamElt v]
sgameltMapInScp scp f = map (\e -> if sgameltInScp scp e then e {sgeVal = f (sgeVal e)} else e)
+{-# INLINE sgameltMapInScp #-}
-- extract the in scopes
sgameltGetFilterInScp :: Scp -> (v -> v') -> [SGamElt v] -> [v']
sgameltGetFilterInScp scp f es = [ f (sgeVal e) | e <- es, sgameltInScp scp e ]
+{-# INLINE sgameltGetFilterInScp #-}
%%]
%%[8
-- filter out the out of scopes, applying a mapping function on the fly
mapFilterInScp' :: Ord k => Scp -> ([SGamElt v] -> [SGamElt v]) -> SMap k v -> SMap k v
mapFilterInScp' scp f m
- -- = Map.mapMaybe (\es -> maybeNull Nothing (Just . f) $ sgameltFilterInScp scp es) m
= varmpMapMaybe (\es -> maybeNull Nothing (Just . f) $ sgameltFilterInScp scp es) m
+{-# INLINE mapFilterInScp' #-}
mapFilterInScp :: Ord k => Scp -> (SGamElt v -> SGamElt v) -> SMap k v -> SMap k v
mapFilterInScp scp f m
= mapFilterInScp' scp (map f) m
+{-# INLINE mapFilterInScp #-}
sgamFilterInScp :: Ord k => SGam k v -> SGam k v
sgamFilterInScp g@(SGam {sgScp = scp, sgMap = m})
= g {sgMap = mapFilterInScp scp id m}
+{-# INLINE sgamFilterInScp #-}
%%]
%%[8 export(sgamFilterMapEltAccumWithKey,sgamMapEltWithKey,sgamMapThr,sgamMap)
@@ -182,12 +189,20 @@ sgamSingleton :: k -> v -> SGam k v
sgamSingleton = sgamMetaLevSingleton metaLevVal
%%]
-%%[8 export(sgamUnion)
+%%[8 export(sgamUnionWith,sgamUnion)
-- combine gam, g1 is added to g2 with scope of g2
-sgamUnion :: Ord k => SGam k v -> SGam k v -> SGam k v
-sgamUnion g1@(SGam {sgScp = scp1, sgMap = m1}) g2@(SGam {sgScp = scp2@(hscp2:_), sgMap = m2})
- = g2 {sgMap = varmpUnionWith (++) m1' m2}
+sgamUnionWith :: Ord k => Maybe (v -> [v] -> [v]) -> SGam k v -> SGam k v -> SGam k v
+sgamUnionWith cmb g1@(SGam {sgScp = scp1, sgMap = m1}) g2@(SGam {sgScp = scp2@(hscp2:_), sgMap = m2})
+ = g2 {sgMap = varmpUnionWith cmb' m1' m2}
where m1' = mapFilterInScp scp1 (\e -> e {sgeScpId = hscp2}) m1
+ cmb' = maybe (++)
+ (\c -> \l1 l2 -> concat [ map (SGamElt scp) $ foldr c [] $ map sgeVal g | g@(SGamElt {sgeScpId = scp} : _) <- groupSortOn sgeScpId $ l1 ++ l2 ])
+ cmb
+
+-- combine gam, g1 is added to g2 with scope of g2
+sgamUnion :: Ord k => SGam k v -> SGam k v -> SGam k v
+sgamUnion = sgamUnionWith Nothing
+{-# INLINE sgamUnion #-}
%%]
%%[8 export(sgamPartitionEltWithKey,sgamPartitionWithKey)
View
56 EHC/src/ehc/HS/NameAnalysis.cag
@@ -102,10 +102,12 @@ mkDefOccGam'' l r mka os
mkDefOccGam' :: NmLev -> Range -> (IdOcc -> IdAspect) -> [IdOcc] -> IdDefOccGam
mkDefOccGam' l r mka os
= mkDefOccGam'' l r (\_ -> mka) (zip (repeat undefined) os)
+{-# INLINE mkDefOccGam' #-}
mkDefOccGam :: NmLev -> Range -> IdAspect -> [IdOcc] -> IdDefOccGam
mkDefOccGam l r a os
= mkDefOccGam' l r (const a) os
+{-# INLINE mkDefOccGam #-}
%%]
%%[3 hs
@@ -422,7 +424,7 @@ SEM AGItf
%%[1.initIdGam
SEM Body
| Body
- loc . idGam = gamAddGam @declarations.idDefOccGam @lhs.idGam
+ loc . idGam = gamUnion @declarations.idDefOccGam @lhs.idGam
%%]
TBD: 20100205 AD: The code below to remap identifiers should be revised. Too complex.
@@ -470,26 +472,26 @@ SEM Body
as n = Map.findWithDefault n n @importdeclarations.modAsMp
-- compute new gamma holding proper mapping for unqualified & qualified idents
mkg sel g
- = gamFromAssocL
+ = foldr idDefOccGamUnion emptyGam
[ {- tr "NameAnalysis.mkg" (o >#< ns)
- $ -} (o {ioccNm = n},d {doccNmAlts = Just ns})
+ $ -} gamSingleton (o {ioccNm = n}) (d {doccNmAlts = Set.fromList ns})
| (o,d) <- gamToAssocL g
, (n,es) <- sel o
, let ns = [ ioccNm eo | e <- es, let eo = mentIdOcc e, ioccKind eo == ioccKind o ]
]
gnew = mkg (lks False) @lhs.idGam
- in mkg (lks False) @declarations.idDefOccGam `gamUnion` gnew
+ in mkg (lks False) @declarations.idDefOccGam `idDefOccGamUnion` gnew
%%]
%%[1
SEM Expression
| Let
- loc . idGam = gamAddGam @declarations.idDefOccGam @lhs.idGam
+ loc . idGam = gamUnion @declarations.idDefOccGam @lhs.idGam
| Lambda
- expression . idGam = gamAddGam @patterns.idDefOccGam @lhs.idGam
+ expression . idGam = gamUnion @patterns.idDefOccGam @lhs.idGam
%%[[3
| Typed
- type . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ type . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%]]
%%[[5
| Comprehension
@@ -506,13 +508,13 @@ SEM Expression
%%[4
SEM Pattern
| Typed
- type . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ type . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%]
%%[4
SEM LeftHandSide
| Typed
- type . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ type . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%]
%%[3
@@ -524,7 +526,7 @@ SEM Declaration
%%[[(90 codegen)
ForeignExport
%%]]
- type . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ type . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%[[5
| Data Newtype
%%[[11
@@ -533,27 +535,27 @@ SEM Declaration
%%[[31
GADT
%%]]
- loc . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%]]
%%[[6
| KindSignature
- kind . idGam = gamAddGam @idDefOccGamKind @lhs.idGam
+ kind . idGam = gamUnion @idDefOccGamKind @lhs.idGam
%%]]
%%[[9
| Class
-- simpletype . idGam = @lhs.idGam -- avoid cycles
- loc . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamType @lhs.idGam
. idDefOccGamInstForClass
= fst $ gamPartition (\_ d -> case doccAsp d of {IdAsp_Inst_Def _ n | n == @classrefname -> True ; _ -> False}) $ @lhs.idGam
| Instance
- loc . idGam = gamAddGam @idDefOccGamType @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamType @lhs.idGam
%%]]
%%]
%%[1
SEM FunctionBinding
| FunctionBinding
- righthandside . idGam = gamAddGam @lefthandside.idDefOccGam @lhs.idGam
+ righthandside . idGam = gamUnion @lefthandside.idDefOccGam @lhs.idGam
%%]
%%[1
@@ -562,45 +564,45 @@ SEM RightHandSide
%%[[5
Guarded
%%]
- loc . idGam = gamAddGam @where.idDefOccGam @lhs.idGam
+ loc . idGam = gamUnion @where.idDefOccGam @lhs.idGam
%%]
%%[5
SEM Alternative
| Alternative
- righthandside . idGam = gamAddGam @pattern.idDefOccGam @lhs.idGam
+ righthandside . idGam = gamUnion @pattern.idDefOccGam @lhs.idGam
SEM Qualifier
| Let
- loc . idGam = gamAddGam @declarations.idDefOccGam @lhs.idGam
+ loc . idGam = gamUnion @declarations.idDefOccGam @lhs.idGam
| Generator
- lhs . idGam = gamAddGam @pattern.idDefOccGam @lhs.idGam
+ lhs . idGam = gamUnion @pattern.idDefOccGam @lhs.idGam
%%]
%%[9
SEM Statement
| Let
- loc . idGam = gamAddGam @declarations.idDefOccGam @lhs.idGam
+ loc . idGam = gamUnion @declarations.idDefOccGam @lhs.idGam
| Generator
- lhs . idGam = gamAddGam @pattern.idDefOccGam @lhs.idGam
+ lhs . idGam = gamUnion @pattern.idDefOccGam @lhs.idGam
%%]
%%[4
SEM Type
| Forall Exists
- loc . idGam = gamAddGam @idDefOccGamInside @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamInside @lhs.idGam
%%]
%%[6
SEM Kind
| Forall
- loc . idGam = gamAddGam @idDefOccGamInside @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamInside @lhs.idGam
%%]
%%[13
SEM ContextItem
| Forall
- loc . idGam = gamAddGam @idDefOccGamInside @lhs.idGam
+ loc . idGam = gamUnion @idDefOccGamInside @lhs.idGam
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -665,9 +667,9 @@ mkUseOccGam opts idGam names kind asp rng
occOfDef = idOccUse {ioccNm = nmOfDef}
idUseOccGam = gamSingleton occOfDef (IdUseOcc occOfDef asp rng (doccForUse mbDef))
errs = case mbDef of
- Just d | isJust (doccNmAlts d) && length alts > 1
- -> [rngLift rng Err_AmbiguousNameRef "name" "name" name alts]
- where alts = fromJust (doccNmAlts d)
+ Just d | Set.size (doccNmAlts d) > 1
+ -> [rngLift rng Err_AmbiguousNameRef "name" k name (Set.toList $ doccNmAlts d)]
+ where k = (show $ ioccKind $ doccOcc d) ++ " (" ++ (showPP $ pp $ doccAsp d) ++ ")"
_ -> []
%%]
View
4 EHC/src/ehc/HS/Parser.chs
@@ -958,7 +958,9 @@ pBody' opts addDecl
<|> pParens ((:) <$> pContextItemBase
<*> ( pImO
<|> (++) <$> pList1 (pCOMMA *> pContextItemBase) <*> pImO
- ) )
+ )
+ <|> pSucceed []
+ )
)
<* pDARROW
where pImO = (:[]) <$ pCOMMA <*> pContextItemImplWild `opt` []
View
20 EHC/src/ehc/NameAspect.chs
@@ -11,6 +11,11 @@
%%[1 export(IdDefOcc(..),emptyIdDefOcc,mkIdDefOcc)
%%]
+%%[50 import(qualified Data.Set as Set)
+%%]
+%%[50 import(EH.Util.Utils)
+%%]
+
%%[9999 import({%{EH}Base.ForceEval})
%%]
@@ -209,7 +214,7 @@ data IdDefOcc
, doccLev :: !NmLev
, doccRange :: !Range
%%[[50
- , doccNmAlts :: !(Maybe [HsName])
+ , doccNmAlts :: !(Set.Set HsName) -- !(Maybe [HsName])
%%]]
}
deriving (Show)
@@ -225,15 +230,24 @@ mkIdDefOcc o a l r = IdDefOcc o a l r
%%[50 -1.mkIdDefOcc hs
mkIdDefOcc :: IdOcc -> IdAspect -> NmLev -> Range -> IdDefOcc
-mkIdDefOcc o a l r = IdDefOcc o a l r Nothing
+mkIdDefOcc o a l r = IdDefOcc o a l r Set.empty
%%]
%%[1
instance PP IdDefOcc where
pp o = doccOcc o >|< "/" >|< doccAsp o >|< "/" >|< doccLev o
%%[[50
- >|< maybe empty (\ns -> "/" >|< ppBracketsCommas ns) (doccNmAlts o)
+ >|< (ppBracketsCommas $ Set.toList $ doccNmAlts o)
+%%]]
%%]
+
+%%[50 hs export(idDefOccLCmb)
+-- | Collapse multiple 'IdDefOcc', remembering duplicates in doccNmAlts
+idDefOccLCmb :: IdDefOcc -> [IdDefOcc] -> [IdDefOcc]
+idDefOccLCmb l1 l2 =
+ [ d {doccNmAlts = Set.unions [Set.insert (ioccNm o) a | (IdDefOcc {doccOcc = o, doccNmAlts = a}) <- g]}
+ | g@(d:_) <- groupSortOn (\d -> (ioccKind $ doccOcc d {-, doccLev d -})) $ l1 : l2
+ ]
%%]
%%[50 hs export(doccStrip)
View
2  EHC/test/regress/99/ControlApplicative1.hs
@@ -5,7 +5,7 @@
module ControlApplicative1 where
-import Control.Applicative
+import Control.Applicative hiding (ZipList)
newtype ZipList a = ZipList [a]
deriving Show
View
2  EHC/test/regress/99/GenerDeriv1.hs
@@ -5,7 +5,7 @@
module GenerDeriv1 where
-import UHC.Generics
+import UHC.Generics hiding (D)
data Bit = OBit | IBit | BitsI Int | BitsC Int
deriving Show
View
8 EHC/test/regress/99/Random1.hs
@@ -14,8 +14,8 @@ intRange = (-100,100)
boolRange :: (Bool, Bool)
boolRange = (False,True)
-floatRange :: (Float,Float)
-floatRange = (-10,10)
+floatRange' :: (Float,Float)
+floatRange' = (-10,10)
doubleRange :: (Double, Double)
doubleRange = (1,20)
@@ -43,10 +43,10 @@ main = do
sg' = read "123" :: StdGen
ri = fst $ randomR intRange sg
rb = fst $ randomR boolRange sg'
- rfs = randomRs floatRange g
+ rfs = randomRs floatRange' g
print (inRange intRange ri)
print (inRange boolRange rb)
- print (all (inRange floatRange) (take 10 rfs))
+ print (all (inRange floatRange') (take 10 rfs))
rollDice :: IO Int
View
14 EHC/text/TopicJavaScript.cltex
@@ -15,6 +15,20 @@
%\newcommand{\Coloneqq}[1]{{::=}}
%%]
+%%[abstractHIW2012
+The Utrecht Haskell Compiler (UHC) has a JavaScript backend. This
+backend has been used to experiment with building applications intended
+to run inside web browsers. In particular we did a port of a small
+client-server application. Although both backend and client-server
+applications in itself are not new, the particular combination allowing
+web browser programming in Haskell is new and interesting because of
+entering otherwise unfamiliar Haskell territory. We discuss the backend,
+the JavaScript FFI, the built client-server application, and the aspects
+of this experiment which went well as the aspects (both in UHC as well
+as the Haskell ecosystem) which need improvement in order to make
+Haskell a viable option for web browser programming.
+%%]
+
%%[abstract
We describe a small web application which was created in order to make secondary school students familiar with functional and logic programming.
The accompanying teaching material explains both Prolog, and for the more advanced students its implementation in Haskell.
Please sign in to comment.
Something went wrong with that request. Please try again.