[make DataConstructors handle polymorphic components. change the translation of types to E
John Meacham <john@repetae.net>**20051205150330] hunk ./DataConstructors.hs 30
+import Type(schemeToType)
hunk ./DataConstructors.hs 38
+import Util.VarName
hunk ./DataConstructors.hs 46
+tipe t = runVarName (tipe' t) where
+    tipe' (TAp t1 t2) = liftM2 eAp (tipe' t1) (tipe' t2)
+    tipe' (TArrow t1 t2) =  do
+        t1' <- tipe' t1
+        t2' <- tipe' t2
+        return $ EPi (tVr 0 (t1')) t2'
+    tipe' (TCon (Tycon n k)) =  return $ ELit (LitCons (toName TypeConstructor n) [] (kind k))
+    tipe' (TGen n (Tyvar { tyvarKind = k })) = return $  EVar (tVr ((n + 1) * 2 ) (kind k))
+    tipe' (TVar tv@Tyvar { tyvarKind = k}) = do
+        v <- lookupName tv
+        return $ EVar $ tVr v (kind k)
+    tipe' (TForAll [] (_ :=> t)) = tipe' t
+    tipe' (TForAll xs (_ :=> t)) = do
+        xs' <- flip mapM xs $ \tv -> do
+            v <- newName [70,72..] () tv
+            return $ tVr v (kind $ tyvarKind tv)
+        t' <- tipe' t
+        return $ foldr EPi t' xs' -- [ tVr n (kind k) | n <- [2,4..] | k <- xs ]
hunk ./DataConstructors.hs 65
-tipe (TAp t1 t2) = eAp (tipe t1) (tipe t2)
-tipe (TArrow t1 t2) =  EPi (tVr 0 (tipe t1)) (tipe t2)
-tipe (TCon (Tycon n k)) =  ELit (LitCons (toName TypeConstructor n) [] (kind k))
-tipe (TGen n (Tyvar { tyvarKind = k })) = EVar (tVr ((n + 1) * 2 ) (kind k))
-tipe (TVar Tyvar {}) = error "tipe': Tyvar"
-tipe (TForAll (Forall [] (_ :=> t))) = tipe t
-tipe (TForAll (Forall xs (_ :=> t))) = foldr ELam (tipe t) [ tVr n (kind k) | n <- [2..] | k <- xs ]
+--tipe (TForAll (Forall xs (_ :=> t))) = foldr EPi (tipe t) [ tVr n (kind k) | n <- [2,4..] | k <- xs ]
+
+
hunk ./DataConstructors.hs 326
-            conType = ty',
+            conType =tipe $ schemeToType scheme, -- ty',
hunk ./DataConstructors.hs 340
-            Just (Forall _ (_ :=> ty)) = Map.lookup nm' cm
+            --ty' = tipe $ schemeToType scheme
+            Just scheme@(Forall _ (_ :=> ty)) = Map.lookup nm' cm
hunk ./DataConstructors.hs 413
-    f v | (e,ts@(_:_)) <- fromLam v = do
+    f v | (e,ts@(_:_)) <- fromPi v = do
hunk ./E/FromHs.hs 8
-import Prelude hiding((&&),(||),not,and,or,any,all)
+import Prelude hiding((&&),(||),not,and,or,any,all,head)
hunk ./E/FromHs.hs 48
+head (x:_) = x
+head _ = error "FromHsHeadError"
hunk ./FrontEnd/KindInfer.hs 528
-aHsTypeToType kt (HsTyVar name) = TVar $ tyvar  name (kindOf name kt) Nothing
+aHsTypeToType kt (HsTyVar name) = TVar $ toTyvar kt name --  tyvar  name (kindOf name kt) Nothing
hunk ./FrontEnd/KindInfer.hs 536
-aHsTypeToType kt (HsTyForall vs qt) = TForAll (aHsQualTypeToScheme kt qt)
+--aHsTypeToType kt (HsTyForall vs qt) = TForAll map (kindOf (aHsQualTypeToScheme kt qt)
+aHsTypeToType kt (HsTyForall vs qt) = TForAll (map (toTyvar kt . hsTyVarBindName) vs) (aHsQualTypeToQualType kt qt)
hunk ./FrontEnd/KindInfer.hs 541
+toTyvar kt name =  tyvar  name (kindOf name kt) Nothing
hunk ./FrontEnd/Representation.hs 33
+    tForAll,
hunk ./FrontEnd/Representation.hs 67
-           | TForAll Scheme
+           | TForAll [Tyvar] (Qual Type)
hunk ./FrontEnd/Representation.hs 98
+tForAll [] ([] :=> t) = t
+tForAll vs (ps :=> TForAll vs' (ps' :=> t)) = tForAll (vs ++ vs') ((ps ++ ps') :=> t)
+tForAll x y = TForAll x y
+
hunk ./FrontEnd/Representation.hs 235
-           TForAll scheme -> do
-            r <- prettyPrintSchemeM scheme
-            return $ text "(forall . " <> r <> text ")"
+           TForAll vs t  -> do
+            r <- prettyPrintQualTypeM t
+            return $ text "(forall" <+> hsep (map pprint vs) <> text " . " <> r <> text ")"
hunk ./FrontEnd/Representation.hs 399
+instance  DocLike d => PPrint d Tyvar where
+  pprint tv = tshow (tyvarName tv)
hunk ./FrontEnd/Representation.hs 445
-   = VarName (\state -> let oldNames = names state
-                        in (head oldNames, state {names = tail oldNames}))
+   = VarName (\state -> let (nn:rns) = names state
+                        in (nn, state {names = rns}))
hunk ./FrontEnd/TIMain.hs 195
-        let tsEs     = map snd pstsEs
+        let tsEs@(htsEs:_)  = map snd pstsEs
hunk ./FrontEnd/TIMain.hs 201
-        return (pse ++ psPats ++ psEs, env1 `Map.union` envAlts, head tsEs)
+        return (pse ++ psPats ++ psEs, env1 `Map.union` envAlts, htsEs)
hunk ./FrontEnd/TIMain.hs 232
-        let typeList = map trd3 psasts
+        let typeList@(htl:_) = map trd3 psasts
hunk ./FrontEnd/TIMain.hs 236
-        return (preds, env1, TAp tList (head typeList))
+        return (preds, env1, TAp tList htl)
hunk ./FrontEnd/TIMain.hs 401
-        let rhsTs      = map trd3 rhsPsEnvTs
+        let rhsTs@(h':_) = map trd3 rhsPsEnvTs
hunk ./FrontEnd/TIMain.hs 406
-        return (guardPs ++ rhsPs, guardEnv `Map.union` rhsEnv, head rhsTs)
+        return (guardPs ++ rhsPs, guardEnv `Map.union` rhsEnv, h')
hunk ./FrontEnd/TIMain.hs 442
-        let ts' = map trd3 psEnvts
+        let ts'@(h':_) = map trd3 psEnvts
hunk ./FrontEnd/TIMain.hs 445
-        return (ps', matchesEnv, head ts')
+        return (ps', matchesEnv, h')
hunk ./FrontEnd/TIMain.hs 495
-        let rhsTs      = map trd3 rhsPsEnvTs
+        let rhsTs@(h':_)      = map trd3 rhsPsEnvTs
hunk ./FrontEnd/TIMain.hs 500
-        return (guardPs ++ rhsPs, guardEnv `Map.union` rhsEnv, head rhsTs)
+        return (guardPs ++ rhsPs, guardEnv `Map.union` rhsEnv, h')
hunk ./FrontEnd/TIMain.hs 781
-        (ps, env, ts) <- tiPats pats
+        (ps, env, ts@(hts:_)) <- tiPats pats
hunk ./FrontEnd/TIMain.hs 783
-        return (ps, env, TAp tList (head ts))
+        return (ps, env, TAp tList hts)
hunk ./FrontEnd/TIModule.hs 55
-isGlobal (Qual _ x) =  not $ isDigit $ head (hsIdentString x)
+isGlobal (Qual _ x) | (h:_) <- hsIdentString x =  not $ isDigit h
hunk ./FrontEnd/TIModule.hs 69
-    (local,global) = partition (\(x,_) -> isDigit $ head (hsIdentString (hsNameIdent x)) ) es
+    (local,global) = partition (\ (x,_) -> not (isGlobal x)) es -- isDigit $ head (hsIdentString (hsNameIdent x)) ) es
hunk ./FrontEnd/TIModule.hs 241
-    let moduleName = modInfoName (head ms)
+    let moduleName = modInfoName tms
+        (tms:_) = ms
hunk ./FrontEnd/TIMonad.hs 162
-           Nothing
-            --  | Just n <- fromTupname conName -> return (toTuple n)
-            | otherwise -> error $ "dConScheme: constructor not found: " ++ show conName ++
+           Nothing -> error $ "dConScheme: constructor not found: " ++ show conName ++
hunk ./FrontEnd/Type.hs 43
+             schemeToType,
hunk ./FrontEnd/Type.hs 49
+import Control.Monad.Writer
+import Data.IORef
hunk ./FrontEnd/Type.hs 54
+import GenUtil
hunk ./FrontEnd/Type.hs 56
-import Representation
hunk ./FrontEnd/Type.hs 57
-import Data.IORef
+import Representation
hunk ./FrontEnd/Type.hs 99
-  kind (TForAll (Forall _ (_ :=> t))) = kind t
+  kind (TForAll _ (_ :=> t)) = kind t
hunk ./FrontEnd/Type.hs 261
+
+schemeToType :: Scheme -> Type
+schemeToType (Forall _ (ps :=> t)) = tForAll (snub xs) (ps' :=> t') where
+    ((ps',t'),xs) = runWriter $ do
+        ps' <- mapM uq' ps
+        t' <- uq t
+        return (ps',t')
+    uq (TAp a b) = liftM2 TAp (uq a) (uq b)
+    uq (TArrow a b) = liftM2 TArrow (uq a) (uq b)
+    uq (TGen _ tv) = do
+        tell [tv]
+        return $ TVar tv
+    uq (TForAll xs (ps :=> t)) = do
+        ps' <- mapM uq' ps
+        t' <- uq t
+        return $ tForAll xs (ps' :=> t')
+    uq x = return x
+    uq' (IsIn s t) = liftM (IsIn s) (uq t)
hunk ./test/Forall.hs 7
-    deriving(Show)
+--    deriving(Show)
hunk ./test/Forall.hs 72
---data Fred = Fred (forall a . a -> a) ((forall a . (forall b . b -> a ) -> a) -> Int)
+data Fred = Fred (forall a . a -> a) ((forall a . (forall b . b -> a ) -> a) -> Int)
hunk ./test/Forall.hs 74
-f (Bob x) = x 'y'
+--f (Bob x) = x 'y'
hunk ./test/Forall.hs 77
-    putChar $ f (Bob id)
+--    putChar $ f (Bob id)