top-level toy compiler - far from complete

devel/compiler/Compile.hs

@@ -0,0 +1,35 @@
+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
+    addTypedef p $ TVal $ toInteger $ fst v
+    vals <- allParVals cs
+    addPartype (TBas p) vals
+    mapM_ (uncurry addParVal) (zip vals (map VPar [0..])) 
+  DOpty a ty -> do
+    addTypedef a ty

devel/compiler/Env.hs

@@ -0,0 +1,52 @@
+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,
+  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
+
+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)}))
+
+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)}))

devel/compiler/Eval.hs

@@ -2,21 +2,57 @@ module Eval where
 
 import AbsSrc
 import AbsTgt
+import SMacros
+import TMacros
 
-import qualified Data.Map as M
+import ComposOp
+import STM
+import Env
 
-eval :: Env -> Exp -> Val
-eval env e = case e of
-  ECon c -> look c
-  EStr s -> VTok s
-  ECat x y -> VCat (ev x) (ev y)
- where 
-   look = lookCons env
-   ev = eval env
+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 -> checks [
+        do
+        v <- lookEnv values c
+        return $ appVal v xs'  
+       ,
+        do
+        e <- lookEnv opers c
+        v <- eval e
+        return $ appVal v xs'
+        ]
+  ECon c -> lookEnv values c
+  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
 
-data Env = Env {
-  constants :: M.Map Ident Val
-  }
+  ETab cs -> do
+    vs <- mapM eval [e | Cas _ e <- cs] ---- expand and pattern match
+    return $ VRec vs
+   
+
+  ESel t v -> do
+    t' <- eval t
+    v' <- eval v
+    ---- pattern match first
+    return $ compVal [] $ VPro t' v' ---- []
+
+  EPro t v -> do
+    t' <- eval t
+    ---- project first
+    return $ VPro t' (VPar 666) ---- lookup label
 
-lookCons :: Env -> Ident -> Val
-lookCons env c = maybe undefined id $ M.lookup c $ constants env

devel/compiler/Param.hs

@@ -1,38 +1,34 @@
-type Param  = (Id,[Constr])
-type Constr = (Id,[Id])
-type Source = [Param] 
-type Id     = String
+module Param where
 
-type Target = [(Id,((Int,Int),[Id]))]
+import AbsSrc
+import SMacros
 
-compile :: Source -> Target
-compile src = ctyps ++ incss where
-  ctyps = map compT src
-  (typs,cons) = unzip src
-  compT (ty,cs) = 
-    (ty,((sum [product [size t | t <- ts] | (_,ts) <- cs],length cs),[]))
-  size ty = maybe undefined (fst . fst) $ lookup ty ctyps
-  incss = concat $ map (incs 0) cons
-  incs k cs = case cs of
-    (c,ts):cs2 -> 
-      let s = product (map size ts) in (c,((s,k),ts)) : incs (k+s) cs2
-    _ -> []
+import Env
+import STM
 
-newtype Value = V (Id,[Value])
+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 lookParTypeSize ts
+    return $ product ats
 
-value :: Target -> Value -> Int
-value tg (V (f,xs)) = maybe undefined (snd . fst) (lookup f tg) + posit xs where
-  posit xs = 
-    sum [value tg x * product [size p | (_,p) <- xs2] | 
-                                i         <- [0..length xs -1], 
-                                let (x,_):xs2 = drop i (zip xs args)
-        ]
-  args = maybe undefined snd $ lookup f tg
-  size p = maybe undefined (fst . fst) $ lookup p tg
+lookParTypeSize :: Type -> STM Env Int
+lookParTypeSize ty = case ty of
+  TBas c -> do
+    ty' <- lookEnv typedefs c
+    lookParTypeSize ty'
+  TVal i -> return $ fromInteger i
 
-ex1 :: Source
-ex1 = [
-  ("B",[("T",[]),("F",[])]),
-  ("G",[("M",[]),("Fe",[]),("N",[])]),
-  ("Q",[("Q1",["B"]),("Q2",["B","B"]),("Q3",["B","B","B"])])
-  ]
+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]

devel/compiler/PrEnv.hs

@@ -0,0 +1,47 @@
+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 "--# values"
+  mapM_ putStrLn 
+    [prs c ++ " = " ++ prt val | (c,val) <- M.toList $ values env]
+  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]
+
+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
+  }
+-}

devel/compiler/SMacros.hs

@@ -0,0 +1,16 @@
+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

devel/compiler/STM.hs

@@ -0,0 +1,94 @@
+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"
+

devel/compiler/Src.cf

@@ -36,10 +36,11 @@ ETab. Exp1  ::= "table" "{" [Case] "}" ;
 ETbv. Exp1  ::= "table" "(" Type ")" "{" [Exp] "}" ;
 ECat. Exp  ::= Exp "++" Exp1 ;
 EAbs. Exp  ::= "\\" Ident "->" Exp ;
+ECst. Exp2 ::= "(" Ident "@" [Exp] ")" ;
 
 coercions Exp 2 ;
 
-separator Exp ";" ;
+separator Exp "," ;
 
 FExp. Assign ::= Ident "=" Exp ;
 

devel/compiler/TMacros.hs

@@ -0,0 +1,16 @@
+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 
+    VArg i   -> args !! fromInteger i
+    VCat x y -> VCat (comp x) (comp y)
+    _ -> val

devel/compiler/Tgt.cf

@@ -2,7 +2,7 @@
 
 Tg. Object ::= [Fun] ;
 
-FVal. Fun ::= Ident "=" Val ;
+FVal. Fun ::= Id "=" Val ;
 
 terminator Fun ";" ;
 
@@ -14,3 +14,5 @@ VPar. Val ::= Integer ;
 VCat. Val ::= "(" Val Val ")" ;
 
 terminator Val "," ;
+
+token Id (letter | '_') (letter | digit | '_' | '\'')* ;

devel/compiler/Top.hs

@@ -0,0 +1,34 @@
+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
+

devel/compiler/ex.src

@@ -1,6 +1,8 @@
 param Num = Sg | Pl ;
 param Gen = Masc | Fem ;
 
+param AG = A Num Gen ;
+
 oper Agr = {g : Gen ; n : Num} ;
 
 oper CN = {s : Num -> Str ; g : Gen} ;
@@ -9,7 +11,7 @@ oper NP = {s : Str ; a : Agr} ;
 oper artDef : Gen -> Str = \g -> table {
   (Masc) => "le" ;
   (Fem) => "la"
-} ! g ;
+} ! $g ;
 
 
 lin Voiture : CN = {
@@ -17,15 +19,18 @@ lin Voiture : CN = {
     (Sg) => "voiture" ;
     (Pl) => "voitures"
   } ;
-  g = Fem
+  g = (Fem@)
 } ;
 
+{-
 lin Bus : CN = {
   s = table {$x => "bus"} ;
-  g = Masc
+  g = (Masc@)
 } ;
 
+
 lin Def : CN -> NP = \cn -> {
-  s = artDef cn.g ++ cn.s ! Sg ;
-  a = {g = cn.g ; n = Sg} 
+  s = artDef $cn.g ++ $cn.s ! (Sg@) ;
+  a = {g = $cn.g ; n = (Sg@)} 
 } ;
+-}