-- The Term type is abstract.
class (Eq a, Show a) => Term a where
    value :: Term a -> Bool      -- a value (leaf) Term
    rator :: Term a -> String    -- term's operator
    rands :: Term a -> [Term a]  -- term's arguments
    var   :: String -> Term a    -- create a variable
    
-- Code is a Term annotated with an environment of expensive Terms
-- corresponding to run-time intermediate values.
data (Term a) => Env a  = Env [a] deriving Show
data (Term a) => Code a = Code { term :: a, env :: Env a }

env0   = Env []
env1 p = Env [p]

-- Prettyprinting for single and multiple return values.
instance (Show a, Eq a) => Show (Code a) 
    where show = valueShow
          showList = \cs acc -> (valuesShow cs) ++ acc
valueShow  :: (Show a, Eq a) => (Code a) -> String
valuesShow :: (Show a, Eq a) => [(Code a)] -> String

instance Eq a => Eq (Code a) where x == y = x `valueEq` y
(Code ra ea) `valueEq` (Code rb eb) = ra == rb



-- Syntax for ANF/SSA assembly language
-- Let      : dest rator [rand]
-- Function : in locals out
data Symbol   = Symbol   String 
data Let      = Let      Symbol Symbol [Symbol]  deriving Show
data Function = Function [Symbol] [Let] [Symbol] deriving Show

-- Compile a list of Term objects relative to an Env dictionary object
-- to a flat syntax by naming the expressions in the dictionary.

registers = map (\x -> Symbol ("r" ++ (show x))) [1..] 

function :: (Show a, Eq a) => Env a -> [Term a] -> Function
function (Env vars ops) retvals =
    let ops'  = reverse ops                        -- both are stacks
        vars' = []  -- FIXME (not tracked)
        dict  = zip ops' registers
        def (prim, reg) =
            let b o as = Let reg o (map (showTerm dict) as) in
            case prim of
              APrim o a1 a2 -> b o [a1, a2]
              CPrim o a1 a2 -> b o [a1, a2]
              Prim o as -> b o as
    in
      Function vars' (map def dict) (map (showTerm dict) retvals)

code (Code term env) = function env [term]
codes cs = 
    let terms = map term cs
        env'  = foldr merge env0 (map env cs) in
    function env' terms

-- Print a Term given a dictionary of Prim -> register name mappings.
showTerm dict term = case term of
                       (Lit f) -> Symbol (show f) -- FIXME
                       (Var v) -> v 
                       (Node op) -> case (lookup op dict) of
                                      Just reg -> reg

-- Convert syntax tree to C code String
showC typ fname (Function vars bindings retval) =
    body (decl (show fname) (map show vars))
         (map local bindings)
         (ret retval)
    where
      typed a = (show typ) ++ " " ++ a
      indent = "    "
      statement st = indent ++ st ++ ";\n"
      arglist as = concat $ 
                   case concat $ map (\a -> [", ", a]) as of 
                     s:ss -> ss; [] -> []
      decl o as = app (typed o) (map typed as) 
      app o as = o ++ "(" ++ (arglist as) ++ ")" 
      body d l v = d ++ " {\n" ++ (concat l) ++ v ++ "}\n" 
      local (Let d o as) 
          = statement $ 
            (typed (show d)) ++ " = " ++ (app (show o) (map show as))
      ret rvs = statement $ app "return" (map show rvs)
          
functionShow (Function vars bindings retvals) =
    "in:  " ++ show vars ++ "\n" ++
    (concat $ map (\(Let d o as) 
                       -> show d ++ " <- " ++ 
                          show o ++ " " ++ show as ++ "\n") 
                  bindings) ++
    "out: " ++ show retvals ++ "\n"

-- default printer    
valueShow = functionShow . code
valuesShow = functionShow . codes

-- C printer
cgen t n = (showC t n) . code
cfun :: (Num a) => Code a -> IO ()
cfun = putStr . (cgen (Symbol "float") (Symbol "function"))
  
--- Free variable and literal construction
var n = let s = Symbol n in Code (Var s) (Env [s] [])
lit l = Code (Lit l) env0




--- Abstract interpretation

-- FIXME: The binop, unop functions look a bit ugly.  Re-order the
-- encoding so environment passing is simpler.

-- Performing a binary operation will merge environments and the
-- binary expression, attempting reuse.

-- preserve order (i.e. join != union)

-- Equality is used to join environments and find common expressions.
merge (Env vars ops) (Env vars' ops') = 
    Env (join vars vars') (join ops ops')


reuse op (Env _ ops) =
    case (intersect ops [op]) of
      []    -> op
      [op'] -> op'



postpone :: (Eq a) => Symbol -> ([Code a] -> Code a)
postpone opcode cs =
    let t = Prim opcode (map term cs)
        e = foldr merge env0 ((env1 t) : (map env cs)) in
    Code (Node (reuse t e)) e

binop code fn a b =
    case map term [a,b] of
      [(Lit a), (Lit b)] -> lit (fn a b)
      _ -> postpone (Symbol code) [a,b]

unop code fn a =
    case map term [a] of
      [(Lit a)] -> lit (fn a)
      _ -> postpone (Symbol code) [a]







-- Monad

-- instance Monad (Code (Term a))
--     where return = returnCode 
--           (>>=)  = bindCode

bindCode :: (Code a) -> (a -> Code b) -> (Code b)
returnCode :: a -> Code a

-- Take a code object's term, construct a new code object, and combine
-- the objects.  The choice to make is in what order the environments
-- get joined.


include p ps = if' (p `elem` ps) ps (p:ps)
join xs ys = foldr include ys xs

common op' [] = op'
common op' (op:ops) = if' (op' == op) op (common op' ops)


returnCode r = Code r (case r of
                         Node n -> Env [] [n]
                         Var v  -> Env [v] []
                         Lit l  -> Env [] [])

bindCode (Code t (Env vs ps)) combine =
    case combine t of
      Code t' (Env vs' ps') ->
          let ps'' = join ps ps' 
              vs'' = join vs vs'
              e''  = Env vs'' ps''
          in
            case t' of 
              Node p' -> Code (Node (common p' ps'')) e''
              _ -> Code t' e''
    


-- An environment is a collection of variables and intermediate
-- primitive computations.

env0   = Env [] []
env1 p = Env [] [p]