diff options
| author | aarne <unknown> | 2003-10-08 10:09:58 +0000 |
|---|---|---|
| committer | aarne <unknown> | 2003-10-08 10:09:58 +0000 |
| commit | a979508aa75a3f2b93072d214ca9c75ed874a39c (patch) | |
| tree | 74add47e62a9b5fdb1720a365754f738c3de4b93 /src/GF/Canon | |
| parent | 889e5a92e4e0c40ab249f9f86d0fa2647132d87a (diff) | |
Restored printnames.
Diffstat (limited to 'src/GF/Canon')
| -rw-r--r-- | src/GF/Canon/CMacros.hs | 117 |
1 files changed, 1 insertions, 116 deletions
diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs index 49e9c71e4..e782d977a 100644 --- a/src/GF/Canon/CMacros.hs +++ b/src/GF/Canon/CMacros.hs @@ -149,120 +149,5 @@ allLinValues trm = do redirectIdent n f@(CIQ _ c) = CIQ n c - -{- ---- to be removed 21/9 --- to analyse types and terms into eta normal form - -typeForm :: Exp -> Err (Context, Exp, [Exp]) -typeForm e = do - (cont,val) <- getContext e - (cat,args) <- getArgs val - return (cont,cat,args) - -getContext :: Exp -> Err (Context, Exp) -getContext e = case e of - EProd x a b -> do - (g,b') <- getContext b - return ((x,a):g,b') - _ -> return ([],e) - -valAtom :: Exp -> Err Atom -valAtom e = do - (_,val,_) <- typeForm e - case val of - EAtom a -> return a - _ -> prtBad "atom expected instead of" val - -valCat :: Exp -> Err CIdent -valCat e = do - a <- valAtom e - case a of - AC c -> return c - _ -> prtBad "cat expected instead of" a - -termForm :: Exp -> Err ([A.Ident], Exp, [Exp]) -termForm e = do - (cont,val) <- getBinds e - (cat,args) <- getArgs val - return (cont,cat,args) - -getBinds :: Exp -> Err ([A.Ident], Exp) -getBinds e = case e of - EAbs x b -> do - (g,b') <- getBinds b - return (x:g,b') - _ -> return ([],e) - -getArgs :: Exp -> Err (Exp,[Exp]) -getArgs = get [] where - get xs e = case e of - EApp f a -> get (a:xs) f - _ -> return (e, reverse xs) - --- the inverses of these - -mkProd :: Context -> Exp -> Exp -mkProd c e = foldr (uncurry EProd) e c - -mkApp :: Exp -> [Exp] -> Exp -mkApp = foldl EApp - -mkAppAtom :: Atom -> [Exp] -> Exp -mkAppAtom a = mkApp (EAtom a) - -mkAppCons :: CIdent -> [Exp] -> Exp -mkAppCons c = mkAppAtom $ AC c - -mkType :: Context -> Exp -> [Exp] -> Exp -mkType c e xs = mkProd c $ mkApp e xs - -mkAbs :: Context -> Exp -> Exp -mkAbs c e = foldr EAbs e $ map fst c - -mkTerm :: Context -> Exp -> [Exp] -> Exp -mkTerm c e xs = mkAbs c $ mkApp e xs - -mkAbsR :: [A.Ident] -> Exp -> Exp -mkAbsR c e = foldr EAbs e c - -mkTermR :: [A.Ident] -> Exp -> [Exp] -> Exp -mkTermR c e xs = mkAbsR c $ mkApp e xs - --- this is used to create heuristic menus -eqCatId :: Cat -> Atom -> Bool -eqCatId (CIQ _ c) b = case b of - AC (CIQ _ d) -> c == d - AD (CIQ _ d) -> c == d - _ -> False - --- a very weak notion of "compatible value category" -compatCat :: Cat -> Type -> Bool -compatCat c t = case t of - EAtom b -> eqCatId c b - EApp f _ -> compatCat c f - _ -> False - --- this is the way an atomic category looks as a type - -cat2type :: Cat -> Type -cat2type = EAtom . AC - -compatType :: Type -> Type -> Bool -compatType t = case t of - EAtom (AC c) -> compatCat c - _ -> (t ==) - -type Fun = CIdent -type Cat = CIdent -type Type = Exp - -mkFun, mkCat :: String -> String -> Fun -mkFun m f = CIQ (A.identC m) (A.identC f) -mkCat = mkFun - -mkFunC, mkCatC :: String -> Fun -mkFunC s = let (m,f) = span (/= '.') s in mkFun m (drop 1 f) -mkCatC = mkFunC - --} +ciq n f = CIQ n f |
