[add ability for :grep to print out types of functions and data/type constructors
John Meacham <john@repetae.net>**20051203052027] addfile ./Util/VarName.hs
hunk ./DataConstructors.hs 14
+    pprintTypeOfCons,
hunk ./DataConstructors.hs 40
+import Util.VarName
hunk ./DataConstructors.hs 42
+import Unparse
hunk ./DataConstructors.hs 367
+
+
+pprintTypeOfCons :: DocLike a => DataTable -> Name -> a
+pprintTypeOfCons dataTable name | Just c <- getConstructor name dataTable = pprintTypeAsHs (conType c)
+                                | otherwise = text "?"
+
+
+
+
+pprintTypeAsHs :: DocLike a => E -> a
+pprintTypeAsHs e = unparse $ runVarName (f e) where
+    f e | e == eStar = return $ atom $ text "*"
+        | e == eHash = return $ atom $ text "#"
+    f (EPi (TVr { tvrIdent = 0, tvrType = t1 }) t2) = do
+        t1 <- f t1
+        t2 <- f t2
+        return $ t1 `arr` t2
+    f (ELit (LitCons n as _)) | (a:as') <- reverse as = f $ EAp (ELit (LitCons n (reverse as') undefined)) a
+    f (ELit (LitCons n [] _)) = return $ atom $ text $ show n
+    f (EAp a b) = do
+        a <- f a
+        b <- f b
+        return $ a `app` b
+    f (EVar v) = do
+        vo <- newLookupName ['a' .. ] () (tvrIdent v)
+        return $ atom $ char vo
+    arr = bop (R,0) (space <> text "->" <> space)
+    app = bop (L,100) (text " ")
+
+
+--pprintTypeAsHs (EPi (TVr { tvrIdent = 0, tvrType = t1 }) t2) =
+
hunk ./E/Pretty.hs 102
-instance Unparsable Doc where
-    unparseCat  =  (<>)
-    unparseSpace  =  (<>)
-    unparseGroup  = parens
hunk ./E/Pretty.hs 120
-    atomize (x,_) = (x,Atom)
+    --atomize (x,_) = (x,Atom)
hunk ./E/Pretty.hs 159
-        (ELetRec bg e) -> rtup (Fix L (-10)) $ let
+        (ELetRec bg e) -> fixitize (L,(-10)) $ let
hunk ./E/Pretty.hs 163
-        ec@(ECase { eCaseScrutinee = e, eCaseAlts = alts }) -> rtup (Fix L (-10)) $ let
+        ec@(ECase { eCaseScrutinee = e, eCaseAlts = alts }) -> fixitize ((L,(-10))) $ let
hunk ./FrontEnd/Representation.hs 140
-        --tv' <- refType tv'
hunk ./FrontEnd/Representation.hs 224
-                                    --return (text nm)
-                                    return (text nm <> parens (text (show tv)))
+                                    return (text nm)
+                                    --return (text nm <> parens (text (show tv)))
hunk ./FrontEnd/Representation.hs 272
-   --pprint (Kfun Star k2)   = text "*->" <> text "(" <> pprint k2 <> text ")"
hunk ./Interactive.hs 3
-import Data.Version
hunk ./Interactive.hs 7
-import System.Info
hunk ./Interactive.hs 11
+import DataConstructors
hunk ./Interactive.hs 14
+import Doc.PPrint
+import Representation
hunk ./Interactive.hs 22
-import Version
+import qualified Text.PrettyPrint.HughesPJ as PP
hunk ./Interactive.hs 44
+    dataTable = hoDataTable ho
hunk ./Interactive.hs 65
-            Just rx -> mapM_ putStrLn $ sort [ nameTag (nameType v):' ':show v | v <- Map.keys (hoDefs ho), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]
+            Just rx -> mapM_ putStrLn $ sort [ nameTag (nameType v):' ':show v <+> "::" <+> ptype v  | v <- Map.keys (hoDefs ho), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]
hunk ./Interactive.hs 67
+    ptype k | Just r <- Map.lookup k (hoAssumps ho) = show (pprint r:: PP.Doc)
+    ptype x = pprintTypeOfCons dataTable x
hunk ./Unparse.hs 1
-module Unparse(Unparse, Unparsable(..), unparse, Side(..), Fix(..), atom, bop, pop) where
+module Unparse(Unparse(), Unparsable(..), unparse, unparse', Side(..), atom, atomize, bop, pop, fixitize) where
hunk ./Unparse.hs 3
-type Unparse a = (a, Fix)
+import Doc.DocLike
hunk ./Unparse.hs 5
-class Unparsable a where
-    unparseGroup :: a -> a
+data Unparse a = Atom a | Pre a (Unparse a) | Fix (Unparse a) a (Unparse a) !Side !Int | Atomized (Unparse a) | Fixitized  !Side !Int a
+
+data Side = R | L | N
+    deriving(Eq)
+
+atom :: a -> Unparse a
+atom s = Atom s
+
+atomize :: Unparse a -> Unparse a
+atomize (Atomized x) = Atomized x
+atomize (Atom a) = Atom a
+atomize x = Atomized x
+
+fixitize :: (Side,Int) -> a -> Unparse a
+fixitize (s,i) a = Fixitized s i a
+
+pop :: a -> Unparse a -> Unparse a
+pop = Pre
+
+bop :: (Side,Int) -> a -> Unparse a -> Unparse a -> Unparse a
+bop (s,i) op a b = Fix a op b s i
+
+
+data Unparsable a = Unparsable {
+    unparseGroup :: a -> a,
hunk ./Unparse.hs 31
-    unparseSpace :: a -> a -> a
-    unparseConcat :: [a] -> a
-    unparseConcat = foldl1 unparseCat
+    }
hunk ./Unparse.hs 33
-instance Unparsable String where
-    unparseGroup x = "(" ++ x ++ ")"
-    unparseCat x y =  x ++ y
-    unparseSpace x y = x ++ " " ++ y
-    unparseConcat xs = concat xs
+data Fix = FAtom | FPre | FFix !Side !Int
hunk ./Unparse.hs 35
+unparse :: DocLike a => Unparse a -> a
+unparse up = unparse' Unparsable { unparseGroup = parens, unparseCat = (<>) } up
hunk ./Unparse.hs 38
-instance Unparsable () where
-    unparseGroup _ = ()
-    unparseCat _ _ = ()
-    unparseSpace _ _ = ()
+unparse' :: Unparsable a -> Unparse a -> a
+unparse' Unparsable { unparseGroup = upg, unparseCat = (<>) } up = fst $ f up where
+    f (Atom a) = atom a
+    f (Atomized a) = (fst $ f a, FAtom)
+    f (Fixitized s i a) = (a, FFix s i)
+    f (Pre a up) = pop a (f up)
+    f (Fix a op b s i) = bop (s,i) op (f a) (f b)
hunk ./Unparse.hs 46
-unparse :: Unparsable a => Unparse a -> a
-unparse = fst
+    bop (f1,f2) s (a,FAtom) (b,FAtom)  = (sop s a b, FFix f1 f2)
+    bop f@(f1,f2) s (a,af) (b,bf) | lts L f af  && lts R f bf  = (sop s a b, FFix f1 f2)
+    bop f s (a,af) b | not (lts L f af) = bop f s (mkatom (a,af)) b
+    bop f s a (b,bf) | not (lts R f bf)  = bop f s a (mkatom (b,bf))
+    bop _ _ _ _ = error "bop"
hunk ./Unparse.hs 52
-data Side = R | L | N
-    deriving(Eq)
+    pop s (x, FAtom) = ( s <> x, FPre)
+    pop s x = pop s $ mkatom x
hunk ./Unparse.hs 55
-data Fix = Atom | Pre | Fix !Side !Int
+    atom a = (a,FAtom)
+    mkatom (a,FAtom) = (a,FAtom)
+    mkatom (a,_) = ( upg a , FAtom)
hunk ./Unparse.hs 59
+    sop op a b = a <> (op <> b)
hunk ./Unparse.hs 61
-lts _ _ Atom = True
-lts _ _ Pre = True
-lts _ (_,n') (Fix  _ n ) | n' /= n = n' < n
-lts R (R,_) (Fix  R _ ) = True
-lts L (L,_) (Fix  L _ ) = True
-lts _ _ _ = False
+    lts :: Side -> (Side,Int) -> Fix -> Bool
+    lts _ _ FAtom = True
+    lts _ _ FPre = True
+    lts _ (_,n') (FFix  _ n ) | n' /= n = n' < n
+    lts R (R,_) (FFix  R _ ) = True
+    lts L (L,_) (FFix  L _ ) = True
+    lts _ _ _ = False
+
+
+
+
+
+
hunk ./Unparse.hs 76
-atom :: a -> Unparse a
-atom s = (s, Atom)
hunk ./Unparse.hs 77
+
+--type Unparse a = (a, Fix)
+
+{-
+
hunk ./Unparse.hs 102
+--sop "" a b = a ++ " " ++ b
+sop op a b = unparseSpace a $ unparseSpace op b
+--sopns "" a b = a ++ " " ++ b
+sopns op a b = unparseCat a $ unparseCat op b
hunk ./Unparse.hs 107
+mkatom (a,Atom) = (a,Atom)
+mkatom (a,_) = ( unparseGroup a , Atom)
+
+instance Unparsable Doc where
+    unparseCat  =  (<>)
+    unparseSpace  =  (<>)
+    unparseGroup  = parens
+class Unparsable a where
+    unparseGroup :: a -> a
+    unparseCat :: a -> a -> a
+    unparseSpace :: a -> a -> a
+    unparseConcat :: [a] -> a
+    unparseConcat = foldl1 unparseCat
+
+instance Unparsable String where
+    unparseGroup x = "(" ++ x ++ ")"
+    unparseCat x y =  x ++ y
+    unparseSpace x y = x ++ " " ++ y
+    unparseConcat xs = concat xs
hunk ./Unparse.hs 128
-{-
+instance Unparsable () where
+    unparseGroup _ = ()
+    unparseCat _ _ = ()
+    unparseSpace _ _ = ()
hunk ./Util/VarName.hs 1
+module Util.VarName(
+    VarNameT(),
+    runVarNameT,
+    runVarName,
+    newName,
+    lookupName,
+    newLookupName) where
+
+import Control.Monad.State
+import Control.Monad.Identity
+import qualified Data.Map as Map
+
+newtype VarNameT nc ni no m a = VarName (StateT (Map.Map ni no, Map.Map nc Int) m a)
+    deriving(Monad, MonadTrans, Functor, MonadFix, MonadPlus, MonadIO)
+
+type VarName ni no a = VarNameT () ni no Identity a
+
+
+runVarNameT :: Monad m => VarNameT nc ni no m a -> m a
+runVarNameT  (VarName sm) = evalStateT sm (Map.empty, Map.empty)
+
+runVarName ::  VarName ni no a -> a
+runVarName v = runIdentity $ runVarNameT v
+
+
+newName :: (Ord ni, Ord nc,Monad m) => [no] -> nc -> ni -> VarNameT nc ni no m no
+newName ns nc ni = VarName $ do
+    (nim,ncm) <- get
+    let no = ns!!i
+        Just i = fmap (subtract 1) $ Map.lookup nc ncm'
+        ncm' = Map.insertWith (+) nc 1 ncm
+    put (Map.insert ni no nim, ncm')
+    return no
+
+lookupName :: (Ord ni, Monad m,Show ni) => ni -> VarNameT nc ni no m no
+lookupName t = VarName $ do
+    (nim,_) <- get
+    case Map.lookup t nim of
+        Just x -> return x
+        Nothing -> fail $ "lookupName not found: " ++ show t
+
+
+newLookupName :: (Ord ni, Ord nc,Monad m) => [no] -> nc -> ni -> VarNameT nc ni no m no
+newLookupName ns nc ni = VarName $ do
+    (nim,ncm) <- get
+    case Map.lookup ni nim of
+        Just x -> return x
+        Nothing -> do
+            let no = ns!!i
+                Just i = fmap (subtract 1) $ Map.lookup nc ncm'
+                ncm' = Map.insertWith (+) nc 1 ncm
+            put (Map.insert ni no nim, ncm')
+            return no
+
+
+