updated synopsis, removed GF/devel/

13 files changed, 0 insertions, 540 deletions

diff --git a/devel/compiler/Compile.hs b/devel/compiler/Compile.hs
deleted file mode 100644
index f21fca632..000000000
--- a/devel/compiler/Compile.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module Compile where
-
-import AbsSrc
-import AbsTgt
-import SMacros
-import TMacros
-
-import Eval
-import Param
-
-import STM
-import Env
-
-import qualified Data.Map as M
-
-compile :: Grammar -> Env
-compile (Gr defs) = err error snd $ appSTM (mapM_ compDef defs) emptyEnv
-
-compDef :: Def -> STM Env ()
-compDef d = case d of
-  DLin f ty exp -> do
-    val <- eval exp
-    addType f ty
-    addVal f val
-  DOper f ty exp -> do
-    addType f ty
-    addOper f exp
-  DPar  p cs -> do
-    v <- sizeParType cs
-    let ty = TBas p
-    addParsize ty $ fst v
-    vals <- allParVals cs
-    addPartype ty vals
-    mapM_ (uncurry addParVal) (zip vals (map VPar [0..])) 
-  DOpty a ty -> do
-    addTypedef a ty
diff --git a/devel/compiler/Env.hs b/devel/compiler/Env.hs
deleted file mode 100644
index 7e1d23983..000000000
--- a/devel/compiler/Env.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-module Env where
-
-import AbsSrc
-import AbsTgt
-
-import STM
-import qualified Data.Map as M
-
-data Env = Env {
-  values   :: M.Map Ident Val,
-  types    :: M.Map Ident Type,
-  opers    :: M.Map Ident Exp,
-  typedefs :: M.Map Ident Type,
-  parsizes :: M.Map Type  Int,
-  partypes :: M.Map Type  [Exp],
-  parvals  :: M.Map Exp   Val,
-  vars     :: M.Map Ident Val
----  constrs  :: M.Map Ident ([Int] -> Int)
-  }
-
-emptyEnv = Env M.empty M.empty M.empty M.empty M.empty M.empty M.empty M.empty
-
-lookEnv :: (Show i, Ord i) => (Env -> M.Map i a) -> i -> STM Env a
-lookEnv field c = do
-  s <- readSTM 
-  maybe (raise $ "unknown " ++ show c) return $ M.lookup c $ field s
-
-addVal :: Ident -> Val -> STM Env ()
-addVal c v = updateSTM (\env -> (env{values = M.insert c v (values env)}))
-
-addType :: Ident -> Type -> STM Env ()
-addType c v = updateSTM (\env -> (env{types = M.insert c v (types env)}))
-
-addOper :: Ident -> Exp -> STM Env ()
-addOper c v = updateSTM (\env -> (env{opers = M.insert c v (opers env)}))
-
-addTypedef :: Ident -> Type -> STM Env ()
-addTypedef c v = updateSTM (\env -> (env{typedefs = M.insert c v (typedefs env)}))
-
-addParsize :: Type -> Int -> STM Env ()
-addParsize c v = updateSTM (\env -> (env{parsizes = M.insert c v (parsizes env)}))
-
-addPartype :: Type -> [Exp] -> STM Env ()
-addPartype c v = updateSTM (\env -> (env{partypes = M.insert c v (partypes env)}))
-
-addParVal :: Exp -> Val -> STM Env ()
-addParVal c v = updateSTM (\env -> (env{parvals = M.insert c v (parvals env)}))
-
----addEnv :: (Env -> M.Map Ident a) -> Ident -> a -> STM Env ()
----addEnv field c v = updateSTM (\env -> (env{field = M.insert c v (field env)},()))
-
-addVar :: Ident -> STM Env ()
-addVar x = do
-  s <- readSTM
-  let i = M.size $ vars s
-  updateSTM (\env -> (env{vars = M.insert x (VArg $ toInteger i) (vars env)}))
diff --git a/devel/compiler/Eval.hs b/devel/compiler/Eval.hs
deleted file mode 100644
index f0c4f1303..000000000
--- a/devel/compiler/Eval.hs
+++ /dev/null
@@ -1,57 +0,0 @@
-module Eval where
-
-import AbsSrc
-import AbsTgt
-import SMacros
-import TMacros
-import Match
-import Env
-
-import STM
-
-
-eval :: Exp -> STM Env Val
-eval e = case e of
-  EAbs x b -> do
-    addVar x ---- adds new VArg i
-    eval b
-  EApp _ _ -> do
-    let (f,xs) = apps e
-    xs' <- mapM eval xs
-    case f of
-      ECon c -> do
-        v <- lookEnv values c
-        return $ appVal v xs'  
-      EOpr c -> do
-        e <- lookEnv opers c
-        v <- eval e           ---- not possible in general
-        return $ appVal v xs'
-  ECon c -> lookEnv values c
-  EOpr c -> lookEnv opers c >>= eval ---- not possible in general
-  EVar x -> lookEnv vars x
-  ECst _ _ -> lookEnv parvals e
-  EStr s -> return $ VTok s
-  ECat x y -> do
-    x' <- eval x
-    y' <- eval y
-    return $ VCat x' y'
-  ERec fs -> do
-    vs <- mapM eval [e | FExp _ e <- fs]
-    return $ VRec vs
-
-  ETab ty cs -> do
---    sz <- lookEnv parsizes ty
---    let ps = map (VPar . toInteger) [0..sz-1]
-    ps <- lookEnv partypes ty
-    vs <- mapM (\p -> match cs p >>= eval) ps
-    return $ VRec vs
-   
-  ESel t v -> do
-    t' <- eval t
-    v' <- eval v
-    ---- pattern match first
-    return $ compVal [] $ VPro t' v' ---- []
-
-  EPro t v@(Lab _ i) -> do
-    t' <- eval t
-    return $ compVal [] $ VPro t' (VPar i)
diff --git a/devel/compiler/Match.hs b/devel/compiler/Match.hs
deleted file mode 100644
index a9ac839ef..000000000
--- a/devel/compiler/Match.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module Match where
-
-import AbsSrc
-import AbsTgt
-
-import Env
-import STM
-
-match :: [Case] -> Exp -> STM Env Exp
-match cs v = checks $ map (tryMatch v) cs
-
----- return substitution  
-tryMatch :: Exp -> Case -> STM Env Exp
-tryMatch e (Cas p v) = if fit (e, p) then return v else raise "no fit" where
-  fit (exp,patt) = case (exp,patt) of
-    (ECst c es, PCon d ps) ->
-      c == d  &&
-      length es == length ps &&
-      all fit (zip es ps)
-    (_,PVar _) -> True ---- not is exp contains variables
-
diff --git a/devel/compiler/Param.hs b/devel/compiler/Param.hs
deleted file mode 100644
index 5137faa7b..000000000
--- a/devel/compiler/Param.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module Param where
-
-import AbsSrc
-import SMacros
-
-import Env
-import STM
-
-sizeParType :: [Constr] -> STM Env (Int,Int)
-sizeParType cs = do
-  scs <- mapM sizeC cs
-  return (sum scs, length cs)
- where
-  sizeC (Con c ts) = do
-    ats <- mapM (lookEnv parsizes) ts
-    return $ product ats
-
-allParVals :: [Constr] -> STM Env [Exp]
-allParVals cs = do
-  ess <- mapM alls cs
-  return $ concat ess
- where
-  alls (Con c []) = do
-    return [constr c []]
-  alls (Con c ts) = do
-    ess <- mapM (lookEnv partypes) ts
-    return [constr c es | es <- sequence ess]
diff --git a/devel/compiler/PrEnv.hs b/devel/compiler/PrEnv.hs
deleted file mode 100644
index 910626a42..000000000
--- a/devel/compiler/PrEnv.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-module PrEnv where
-
-import Env
-
-import AbsSrc
-import AbsTgt
-
-import qualified PrintSrc as S
-import qualified PrintTgt as T
-
-import qualified Data.Map as M
-
-prEnv :: Env -> IO ()
-prEnv env = do
-  putStrLn "--# types"
-  mapM_ putStrLn 
-    [prs c ++ " : " ++ prs val | (c,val) <- M.toList $ types env]
-  putStrLn "--# typedefs"
-  mapM_ putStrLn 
-    [prs c ++ " = " ++ prs val | (c,val) <- M.toList $ typedefs env]
-  putStrLn "--# partypes"
-  mapM_ putStrLn 
-    [prs c ++ " = " ++ unwords (map prs val) | (c,val) <- M.toList $ partypes env]
-  putStrLn "--# parvals"
-  mapM_ putStrLn 
-    [prs c ++ " = " ++ prt val | (c,val) <- M.toList $ parvals env]
-  putStrLn "--# values"
-  mapM_ putStrLn 
-    [prs c ++ " = " ++ prt val | (c,val) <- M.toList $ values env]
-
-
-prs :: (S.Print a) => a -> String
-prs = S.printTree
-
-prt :: (T.Print a) => a -> String
-prt = T.printTree
-
-{-
-data Env = Env {
-  values   :: M.Map Ident Val,
-  types    :: M.Map Ident Type,
-  opers    :: M.Map Ident Exp,
-  typedefs :: M.Map Ident Type,
-  partypes :: M.Map Type  [Exp],
-  parvals  :: M.Map Exp   Val,
-  vars     :: M.Map Ident Val
-  }
--}
diff --git a/devel/compiler/SMacros.hs b/devel/compiler/SMacros.hs
deleted file mode 100644
index 46d778234..000000000
--- a/devel/compiler/SMacros.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module SMacros where
-
-import AbsSrc
-
-apps :: Exp -> (Exp,[Exp])
-apps e = (f,reverse xs) where
-  (f,xs) = aps e
-  aps e = case e of
-    EApp f x -> let (f',xs) = aps f in (f',x:xs)
-    _ -> (e,[])
-
-constr :: Ident -> [Exp] -> Exp
-constr = ECst
-
-mkApp :: Exp -> [Exp] -> Exp
-mkApp f = foldl EApp f
diff --git a/devel/compiler/STM.hs b/devel/compiler/STM.hs
deleted file mode 100644
index c3eb38877..000000000
--- a/devel/compiler/STM.hs
+++ /dev/null
@@ -1,94 +0,0 @@
-module STM where
-
-import Control.Monad
-
--- state monad 
-
-
--- the Error monad
-
--- | like @Maybe@ type with error msgs
-data Err a = Ok a | Bad String
-  deriving (Read, Show, Eq)
-
-instance Monad Err where
-  return      = Ok
-  fail        = Bad
-  Ok a  >>= f = f a
-  Bad s >>= f = Bad s
-
--- | analogue of @maybe@
-err :: (String -> b) -> (a -> b) -> Err a -> b 
-err d f e = case e of
-  Ok a -> f a
-  Bad s -> d s
-
--- state monad with error; from Agda 6/11/2001
-
-newtype STM s a = STM (s -> Err (a,s)) 
-
-appSTM :: STM s a -> s -> Err (a,s)
-appSTM (STM f) s = f s
-
-stm :: (s -> Err (a,s)) -> STM s a
-stm = STM
-
-stmr :: (s -> (a,s)) -> STM s a
-stmr f = stm (\s -> return (f s))
-
-instance  Monad (STM s) where
-  return a    = STM (\s -> return (a,s))
-  STM c >>= f = STM (\s -> do 
-                        (x,s') <- c s
-                        let STM f' = f x
-                        f' s')
-
-readSTM :: STM s s
-readSTM = stmr (\s -> (s,s))
-
-updateSTM :: (s -> s) -> STM s () 
-updateSTM f = stmr (\s -> ((),f s))
-
-writeSTM :: s -> STM s ()
-writeSTM s = stmr (const ((),s))
-
-done :: Monad m => m ()
-done = return ()
-
-class Monad m => ErrorMonad m where
-  raise   :: String -> m a
-  handle  :: m a -> (String -> m a) -> m a
-  handle_ :: m a -> m a -> m a
-  handle_ a b =  a `handle` (\_ -> b)
-
-instance ErrorMonad Err where
-  raise  = Bad
-  handle a@(Ok _) _ = a
-  handle (Bad i) f  = f i
-
-instance ErrorMonad (STM s) where
-  raise msg = STM (\s -> raise msg)
-  handle (STM f) g = STM (\s -> (f s) 
-                                `handle` (\e -> let STM g' = (g e) in
-                                                    g' s))
-
--- | if the first check fails try another one
-checkAgain :: ErrorMonad m => m a -> m a -> m a
-checkAgain c1 c2 = handle_ c1 c2
-
-checks :: ErrorMonad m => [m a] -> m a
-checks [] = raise "no chance to pass"
-checks cs = foldr1 checkAgain cs
-
-allChecks :: ErrorMonad m => [m a] -> m [a]
-allChecks ms = case ms of
-  (m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs
-  _ -> return []
-
-doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a
-doUntil cond ms = case ms of
-  a:as -> do
-    v <- a
-    if cond v then return v else doUntil cond as
-  _ -> raise "no result"
-
diff --git a/devel/compiler/Src.cf b/devel/compiler/Src.cf
deleted file mode 100644
index 5a49b2341..000000000
--- a/devel/compiler/Src.cf
+++ /dev/null
@@ -1,68 +0,0 @@
-Gr.  Grammar ::= [Def] ;
-
-DPar.  Def ::= "param" Ident "=" [Constr] ;
-DOper. Def ::= "oper" Ident ":" Type "=" Exp ;
-DOpty. Def ::= "oper" Ident "=" Type ;
-DLin.  Def ::= "lin" Ident ":" Type "=" Exp ;
-
-terminator Def ";" ;
-
-Con. Constr ::= Ident [Type] ;
-
-separator nonempty Constr "|" ;
-
-TBas. Type1 ::= Ident ;
-TVal. Type1 ::= "Ints" Integer ;
-TRec. Type1 ::= "{" [Typing] "}" ;
-TFun. Type  ::= Type1 "->" Type ;
-
-coercions Type 1 ;
-
-terminator Type "" ;
-
-FTyp. Typing ::= Label ":" Type ;
-
-separator Typing ";" ;
-
-Lab.  Label ::= Ident "#" Integer ;
-
-EVar. Exp2 ::= "$" Ident ;
-EOpr. Exp2 ::= "&" Ident ;
-ECon. Exp2 ::= Ident ;
-EVal. Exp2 ::= Integer ;
-EStr. Exp2 ::= String ;
-ECst. Exp2 ::= "(" Ident "@" [Exp] ")" ;
-ERec. Exp2 ::= "{" [Assign] "}" ;
-EApp. Exp1 ::= Exp1 Exp2 ;
-ESel. Exp1 ::= Exp1 "!" Exp2 ;
-EPro. Exp1 ::= Exp1 "." Label ;
-ETab. Exp1 ::= "table" Type "{" [Case] "}" ;
-ECat. Exp  ::= Exp "++" Exp1 ;
-EAbs. Exp  ::= "\\" Ident "->" Exp ;
-
-coercions Exp 2 ;
-
-separator Exp "," ;
-
-FExp. Assign ::= Label "=" Exp ;
-
-separator Assign ";" ;
-
-Cas.  Case ::= Patt "=>" Exp ;
-
-separator Case ";" ;
-
-PVal. Patt ::= Integer ;
-PVar. Patt ::= "$" Ident ;
-PRec. Patt ::= "{" [AssPatt] "}" ;
-PCon. Patt ::= "(" Ident [Patt] ")" ;
-
-terminator Patt "" ;
-
-FPatt. AssPatt ::= Label "=" Patt ;
-
-separator AssPatt ";" ;
-
-comment "--" ;
-comment "{-" "-}" ;
-
diff --git a/devel/compiler/TMacros.hs b/devel/compiler/TMacros.hs
deleted file mode 100644
index f06c34d6d..000000000
--- a/devel/compiler/TMacros.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module TMacros where
-
-import AbsTgt
-
-appVal :: Val -> [Val] -> Val
-appVal v vs = compVal vs v
-
-compVal :: [Val] -> Val -> Val
-compVal args = comp where
-  comp val = case val of
-    VRec vs  -> VRec $ map comp vs
-    VPro r p -> case (comp r, comp p) of
-      (VRec vs, VPar i) -> vs !! fromInteger i 
-      (r',p') -> VPro r' p' ---- not at runtime
-    VArg j
-      | i < length args -> args !! i ---- not needed at runtime
-      | otherwise -> val   ---- not the right thing at compiletime either
-          where i = fromInteger j
-    VCat x y -> VCat (comp x) (comp y)
-    _ -> val
diff --git a/devel/compiler/Tgt.cf b/devel/compiler/Tgt.cf
deleted file mode 100644
index f44184a52..000000000
--- a/devel/compiler/Tgt.cf
+++ /dev/null
@@ -1,18 +0,0 @@
---- target language
-
-Tg. Object ::= [Fun] ;
-
-FVal. Fun ::= Id "=" Val ;
-
-terminator Fun ";" ;
-
-VRec. Val ::= "[" [Val] "]" ;
-VPro. Val ::= "(" Val "." Val ")" ;
-VTok. Val ::= String ;
-VArg. Val ::= "$" Integer ;
-VPar. Val ::= Integer ;
-VCat. Val ::= "(" Val Val ")" ;
-
-terminator Val "," ;
-
-token Id (letter | '_') (letter | digit | '_' | '\'')* ;
diff --git a/devel/compiler/Top.hs b/devel/compiler/Top.hs
deleted file mode 100644
index 64a8a6f70..000000000
--- a/devel/compiler/Top.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-module Main where
-
-import IO ( stdin, hGetContents )
-import System ( getArgs, getProgName )
-
-import LexSrc
-import ParSrc
-import SkelSrc
-import PrintSrc
-import AbsSrc
-
-import Compile
-import PrEnv
-
-import ErrM
-
-type ParseFun a = [Token] -> Err a
-
-myLLexer = myLexer
-
-runFile :: ParseFun Grammar -> FilePath -> IO ()
-runFile p f = readFile f >>= run p
-
-run :: ParseFun Grammar -> String -> IO ()
-run p s = let ts = myLLexer s in case p ts of
-           Bad s    -> do putStrLn "Parse Failed...\n"
-                          putStrLn s
-           Ok  tree -> prEnv $ compile tree
-
-main :: IO ()
-main = do args <- getArgs
-          case args of
-            fs -> mapM_ (runFile pGrammar) fs
-
diff --git a/devel/compiler/ex.src b/devel/compiler/ex.src
deleted file mode 100644
index 241fd96b4..000000000
--- a/devel/compiler/ex.src
+++ /dev/null
@@ -1,45 +0,0 @@
-param Num = Sg | Pl ;
-param Gen = Masc | Fem ;
-
-param AG = A Num Gen ;
-
-oper Agr = {g#0 : Gen ; n#1 : Num} ;
-
-oper CN = {s#1 : Num -> Str ; g#0 : Gen} ;
-oper NP = {s#1 : Str ; a#0 : Agr} ;
-
-oper artDef : Gen -> Str = \g -> table Gen {
-  (Masc) => "le" ;
-  (Fem) => "la"
-} ! $g ;
-
-lin Voiture : CN = {
-  s#1 = table Num {
-    (Sg) => "voiture" ;
-    (Pl) => "voitures"
-  } ;
-  g#0 = (Fem@)
-} ;
-
-
-lin Bus : CN = {
-  s#1 = table Num {$x => "bus"} ;
-  g#0 = (Masc@)
-} ;
-
-lin Indef : CN -> NP = \cn -> {
-  s#1 = table Gen {
-        (Masc) => "un" ;
-        $x     => "une"
-        } ! $cn.g#0 ++ $cn.s#1 ! (Sg@) ;
-  a#0 = {g#0 = $cn.g#0 ; n#1 = (Sg@)} 
-} ;
-
-
-lin Def : CN -> NP = \cn -> {
-  s#1 = &artDef $cn.g#0 ++ $cn.s#1 ! (Sg@) ;
-  a#0 = {g#0 = $cn.g#0 ; n#1 = (Sg@)} 
-} ;
-
-lin UneVoiture : NP = Indef Voiture ;
-lin LaVoiture : NP = Def Voiture ;