1 -- C-like imperative semantics:
    2 
    3 -- expressions have values and side effects (that modify the environment)
    4 -- and they may do output
    5 
    6 module Semantik 
    7 
    8 ( Env
    9 
   10 , FIO, unFIO, forceFIO
   11 
   12 , oops
   13 , moops
   14 
   15 , Fun, mkFun, mkfunction
   16 
   17 , vargs
   18 
   19 , comp
   20 , docomp
   21 
   22 )
   23 
   24 where
   25 
   26 import Maybes
   27 
   28 import Options
   29 
   30 import FiniteMap -- syslib ghc
   31 
   32 import Syntax
   33 import Ids
   34 
   35 import FAcon
   36 
   37 
   38 -- identifiers are bound to functions from Exp^* -> a
   39 -- that is they see the literal form of their arguments
   40 -- they need to evaluate them if they want
   41 -- this is like lisp and allows for (setq foo bar)
   42 
   43 newtype FIO s = FIO (Either String s); unFIO (FIO n) = n
   44 
   45 instance Functor FIO where
   46     fmap f (FIO (Left l)) = FIO (Left l)
   47     fmap f (FIO (Right r)) = FIO (Right (f r))
   48 
   49 instance Monad FIO where
   50     return x = FIO (Right x)
   51     FIO (Left l) >>= f = FIO (Left l)
   52     FIO (Right r) >>= f = f r
   53 
   54 -- instance MonadPlus FIO where
   55 --    mzero = FIO (Left "some error")
   56 
   57 oops :: String -> FIO a
   58 oops cs = FIO (Left cs)
   59 
   60 moops :: Bool -> String -> FIO ()
   61 moops p cs = if p then oops cs else return ()
   62 
   63 forceFIO :: FIO a -> a
   64 forceFIO (FIO (Left l)) = error ("error (FIO): " ++ l)
   65 forceFIO (FIO (Right r)) = r
   66 
   67 
   68 -- only look at the result
   69 docomp opts env arg = 
   70     forceFIO (do { (x, env') <- comp opts env arg; return x } )
   71 
   72 
   73 
   74 -------------------------------------------------------------------
   75 
   76 type Env e a = FiniteMap String (Fun e a)
   77 
   78 data Fun e a = Fun (Opts -> Env e a -> [Exp] -> FIO (a, Env e a))
   79 mkFun f = Fun f; unFun (Fun f) = f
   80 
   81 
   82 --------------------------------------------------------------------
   83 
   84 -- a plain function that evaluates its arguments
   85 
   86 -- mkfunction :: String -> ([a] -> a) -> Fun e a
   87 mkfunction name f = Fun (\ opts env args -> 
   88 
   89     do  { troff opts ("\nentered: " ++ name) (return ())
   90         ; (vals, env1) <- vargs opts env args
   91         ; return (f opts vals, env1)   -- todo: really env1 here?
   92         } )
   93 
   94 
   95 ----------------------------------------------------------------------
   96 
   97 -- evaluate a list of expressions from left to right
   98 -- return list of results
   99 -- thread state through
  100 
  101 -- vargs :: Opts -> Env e a -> [Exp] -> FIO ([a], Env e a)
  102 vargs opts env [] = return ([], env)
  103 vargs opts env (x : xs) = 
  104     do  { (y, env1) <- comp opts env x
  105         ; (ys, env2) <- vargs opts env1 xs
  106         ; return (y : ys, env2)
  107         }
  108 
  109 
  110 -- a computation
  111 -- has a result
  112 -- maybe changes the environment
  113 -- maybe does some FIO
  114 -- sequential composition ";" and assignment "=" are wired in
  115 
  116 -- comp :: Opts -> Env e a -> Exp -> FIO (a, Env e a)
  117 
  118 comp opts env (App id args) | idname id == ";" =
  119     do  { (xs, env1) <- vargs opts env args
  120         ; return (last xs, env1)
  121         }
  122 
  123 comp opts env x @ (App id args) | idname id == "=" =
  124     do  { moops (length args /= 2)
  125                 ( "(=) needs exactly two arguments: " ++ show x )
  126         ; let [lhs, rhs] = args
  127 
  128         ; case lhs of
  129             App id locs -> compbind opts env x (idname id) locs rhs
  130             _ -> oops ( "lhs of (=) must be application of function or operator: " ++ show x )
  131         }
  132 
  133 comp opts env x @ (App id args) =
  134 
  135     troff opts ("\ncomp: " ++ show x ) $
  136 
  137     let name = idname id in case lookupFM env name of
  138         Just f -> unFun f opts env args
  139         Nothing -> -- oops ("identifier " ++ name ++ " not bound")
  140                 -- NO, rather: unbound ids are treated as constructors
  141 
  142                 -- todo: this breaks the abstraction
  143             do { (vs, env1) <- vargs opts env args
  144                 ; return (conTNFA opts id vs, env1)
  145                 }
  146 
  147 
  148 compbind opts env x name locs rhs = 
  149     do  { moops (exists (lookupFM env name))
  150                 ( "identifier already bound: " ++ show x )
  151         
  152         ; if null locs 
  153           then define_value    opts env name rhs       -- see below
  154           else define_function opts env x name locs rhs        -- see below
  155         }
  156 
  157 -------------------------------------------------------------------
  158 
  159 mkconst :: a -> Fun e a
  160 mkconst x =  Fun ( \ opts env args -> do        
  161         { moops (not (null args)) 
  162                 ("a constant cannot have args: " ++ show args)
  163         ; return (x, env)
  164         } )
  165 
  166 -- a value (function with 0 args) is evaluated right now
  167 define_value opts env name rhs =
  168     do  { (v, env1) <- comp opts env rhs -- env1 is ignored
  169         ; let val = mkconst v
  170         ; let env2 = addToFM env name val
  171         ; return (v, env2)
  172         }
  173 
  174 -- a `real' function (with > 0 args) is stored as closure
  175 define_function opts env x name lhsargs rhs =
  176     do  { moops (any (not . isAppId) lhsargs) 
  177                 ( "local args must be ids: " ++ show x )
  178         ; let locs = map (idname . unAppId) lhsargs
  179 
  180         -- here's the semantics of a function call
  181         ; let val = Fun (\ opts env1 args1 -> do       
  182                 -- evaluate args in caller's environment
  183                 { (vs, env2) <- vargs opts env1 args1
  184                 ; moops (length vs /= length locs)
  185                         ( "wrong number of args: " ++ show args1
  186                           ++ ", should be " ++ show (length locs) )
  187                 -- local bindings over callee's environment
  188                 ; let bnds = listToFM (zip locs (map mkconst vs))
  189                 ; let env3 = env1 `plusFM` bnds
  190                 ; (v, env4) <- comp opts env3 rhs
  191                 -- return caller's environment
  192                 ; return (v, env2)
  193                 } )
  194 
  195         ; let env1 = addToFM env name val
  196 
  197 --      ; return (undefined, env1)   -- todo: what to return here?
  198         ; return (conTNFA opts (usercon 0 "defined") [], env1) 
  199 
  200         }
  201 
  202