{-
  * Copyright (c): Uwe Schmidt, FH Wedel
  *
  * You may study, modify and distribute this source code
  * FOR NON-COMMERCIAL PURPOSES ONLY.
  * This copyright message has to remain unchanged.
  *
  * Note that this document is provided 'as is',
  * WITHOUT WARRANTY of any kind either expressed or implied.
-}

module Main
where

import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Maybe

-- ------------------------------------------------------------
--
-- the abstract syntax

type Program	= Stmt

type StmtList	= [Stmt]

data Stmt
    = Assign  Ident  Expr
    | Stmts   StmtList
    | If      Expr  Stmt Stmt
    | While   Expr  Stmt

type Ident	= String

data Expr
    = IntConst	Int
    | BoolConst Bool
    | Var       Ident
    | UnExpr	UnOp  Expr
    | BinExpr	Op    Expr  Expr

data Op = Add | Sub | Mul | Div | Mod | Eq | Neq
	deriving (Eq, Ord)

data UnOp = UPlus | UMinus | Neg
	deriving (Eq, Ord)

-- ------------------------------------------------------------
--
-- example programs

p0, p1, p2 :: Program

p0 = Stmts []		-- the empty program

p1 = Stmts
     [ Assign i ( IntConst 22 )
     , Assign j ( IntConst 20 )
     , While
       ( BinExpr Neq ( Var i ) ( IntConst 0 ) )
       ( Stmts
	 [ Assign i ( BinExpr Sub ( Var i ) ( IntConst 1 ) )
	 , Assign j ( BinExpr Add ( Var j ) ( IntConst 1 ) )
	 ]
       )
     ]
    where
    i = "i"
    j = "j"

p2 = Stmts
     [ Assign x (UnExpr UPlus (IntConst 6))
     , Assign y (IntConst 7)
     , Assign p (IntConst 0)
     , While
       ( BinExpr Neq (Var x) (IntConst 0) )
       ( If ( BinExpr Neq ( BinExpr Mod (Var x) (IntConst 2) ) (IntConst 0) )
	    ( Stmts
	      [ Assign x ( BinExpr Sub (Var x) (IntConst 1) )
	      , Assign p ( BinExpr Add (Var p) (Var y) )
	      ]
	    )
	    ( Stmts
	      [ Assign x ( BinExpr Div (Var x) (IntConst 2) )
	      , Assign y ( BinExpr Mul (Var y) (IntConst 2) )
	      ]
	    )
       )
     ]
    where
    x = "x"
    y = "y"
    p = "p"

-- ------------------------------------------------------------
--
-- the "interpreter" for generating a text representation
-- more specific:
-- two interpeters: one for statements and one for expressions
--
-- the "show" is the equivaltent to "toString" in Java

instance Show Stmt
    where
    show (Assign lhs rhs)
	= lhs ++ " := " ++ show rhs

    show (If cond thenp elsep)
	= "if " ++ show cond ++ nl ++
	  "then" ++ indent (show thenp) ++
	  "else" ++ indent (show elsep) ++
	  "end if"

    show (While cond body)
	= "while " ++ show cond ++ nl ++
	  "do" ++ indent (show body) ++
          "end while"
    show (Stmts [])
	= ""
    show (Stmts (s1:sl))
	= show s1 ++ concatMap (\ s -> ";" ++ nl ++ show s) sl

-- ------------------------------------------------------------

instance Show Expr
    where
    show (IntConst i)
	= show i
    show (BoolConst False)
	= "false"
    show (BoolConst True)
	= "true"
    show (Var id)
	= id
    show (UnExpr op op1)
	= show op ++ " ( " ++ show op1 ++ " )"
    show (BinExpr op op1 op2)
	= "( " ++ show op1 ++ " " ++ show op ++ " " ++ show op2 ++ " )"

instance Show Op
    where
    show Add  = "+"
    show Sub  = "-"
    show Mul  = "*"
    show Div  = "div"
    show Mod  = "mod"
    show Eq   = "=="
    show Neq  = "!="

instance Show UnOp
    where
    show UPlus  = "+"
    show UMinus = "-"
    show Neg    = "!"

-- ------------------------------------------------------------
--
-- auxiliary functions

nl	= "\n"
tab	= "\t"

indent ""
    = nl
indent line
    = concatMap (\ c -> if c == '\n' then nl ++ "  " else [c]) (nl ++ line) ++ nl

-- ------------------------------------------------------------
--
-- 2. example: program execution
--
-- the semantic domains for interpreting a program
--
-- state is an assoc list of variables and values,
-- there are two kinds of values: Ints and Booleans

data State	= State { values :: Map Ident Value }

data Value
    = IntValue	{ intValue  :: Int  }
    | BoolValue { boolValue :: Bool }

-- ------------------------------------------------------------
--
-- auxiliary fuction for readable output of program states

instance Show State
    where
    show (State sl) = concat
		      . map ( \ (id,val) -> id ++ "\t:-> " ++ show val ++ "\n")
		      . M.assocs
		      $ sl

instance Show Value
    where
    show (IntValue i)      = show i
    show (BoolValue True)  = "true"
    show (BoolValue False) = "false"

-- ------------------------------------------------------------
--
-- the statement interpreter

run	:: Stmt -> State
run s	= interprete s (State M.empty)

interprete	:: Stmt -> State -> State
interprete (Assign lhs rhs) state@(State s)
    = State ( update lhs v s )
      where
      v = eval rhs state
      update k v s = M.insert k v s

interprete (Stmts []) state
    = state

interprete (Stmts (s:sl)) state
    = interprete (Stmts sl) state'
      where
      state' = interprete s state

interprete (If cond thenp elsep) state
    = interprete (if boolValue (eval cond state)
		  then thenp
		  else elsep) state

interprete w@(While cond body) state
    = if boolValue (eval cond state)
      then let
	   state' = interprete body state
	   in
	   interprete w state'
      else
      state

-- ------------------------------------------------------------
--
-- the expression interpreter

eval	:: Expr -> State -> Value

eval (IntConst i) _state
    = IntValue i

eval (BoolConst b) _state
    = BoolValue b

eval (Var id) (State s)
    = fromJust (M.lookup id s)

eval (UnExpr op op1) state
    = (fromJust (lookup op fl))
         (eval op1 state)
      where
      fl = [ (UPlus,	uplus)
	   , (UMinus,	uminus)
	   , (Neg,      neg)
	   ]
      uplus  (IntValue  i)	= IntValue i
      uminus (IntValue  i)	= IntValue (-i)
      neg    (BoolValue b)	= BoolValue (not b)


eval (BinExpr op op1 op2) state
    = (fromJust (lookup op fl))
         (eval op1 state)
	 (eval op2 state)
      where
      fl = [ (Add,  add)
	   , (Sub,  sub)
	   , (Mul,  mul)
	   , (Div,  divide)
	   , (Mod,  modulo)
	   , (Eq,   eq)
	   , (Neq,  neq)
	   ]
      add (IntValue i)  (IntValue j)
	  = IntValue (i + j)

      sub (IntValue i)  (IntValue j)
	  = IntValue (i - j)

      mul (IntValue i)  (IntValue j)
	  = IntValue (i * j)

      divide (IntValue i)  (IntValue j)
	  = IntValue (i `div` j)

      modulo (IntValue i)  (IntValue j)
	  = IntValue (i `mod` j)

      eq  (IntValue i)  (IntValue j)
	  = BoolValue (i == j)

      eq  (BoolValue b1) (BoolValue b2)
	  = BoolValue (b1 == b2)

      neq v1 v2
	  = BoolValue (not res)
	    where
	    (BoolValue res) = eq v1 v2

-- ------------------------------------------------------------
--
-- the semantic domains for compiling a program
--
-- the compile time state has three components
-- the environment, a map of variables and
-- associated addresses,
-- a counter for generating label names
-- and the code, a list of instructions so far generated

data CState = CState { vars    :: Env
		     , labcnt  :: Label
		     , code    :: Code
		     }

type Env         = Map Ident Address
type Address     = Int
type Label       = Int
type Code        = [Instr]

data Instr
    = Load    Address
    | Lconst  Int
    | Store   Address
    | Compute Opcode
    | Goto    Label
    | Branch  Label
    | Lab     Label

data Opcode
    = OpAdd | OpSub | OpMul | OpDiv | OpMod | OpEq


-- ------------------------------------------------------------
--
-- aux functions for manipulating the compile state

appendCode	:: Code -> CState -> CState
appendCode cl cs
    = cs { code = code cs ++ cl }

getAddr		:: Ident -> CState -> (Address, CState)
getAddr ident state
    = newAdr (M.lookup ident (vars state))
      where
      newAdr (Just adr)
	  = (adr, state)
      newAdr Nothing
	  = (next, state { vars = M.insert ident next (vars state) })
	     where
	     next = M.size (vars state)

newLabel	:: CState -> (Label, CState)
newLabel state
    = (labcnt state, state {labcnt = labcnt state + 1})

-- ------------------------------------------------------------
--
-- show assebmler code
--
-- for readable output of assembler instructions

instance Show CState
    where
    show state = showCode (code state)

instance Show Opcode
    where
    show OpAdd = "add"
    show OpSub = "sub"
    show OpMul = "mul"
    show OpDiv = "div"
    show OpMod = "mod"
    show OpEq  = "eq"

instance Show Instr
    where
    show (Load adr) 	    = tab ++ "load"   ++ tab ++ "m(" ++ show adr ++ ")"
    show (Lconst v)	    = tab ++ "lcnst"  ++ tab ++ show v
    show (Store adr) 	    = tab ++ "store"  ++ tab ++ "m(" ++ show adr ++ ")"
    show (Compute op)       = tab ++ show op
    show (Goto lab)	    = tab ++ "jump"   ++ tab ++ "l" ++ show lab
    show (Branch lab)       = tab ++ "branch" ++ tab ++ "l" ++ show lab
    show (Lab lab) 	    = "l" ++ show lab ++ ":"

showCode	:: Code -> String
showCode
    = concatMap ((++ "\n") . show)

-- ------------------------------------------------------------
--
-- the compile functions

compile	:: Program -> CState
compile	p
    = cstmt p initialCState
      where
      initialCState = CState M.empty 0 []

-- ------------------------------------------------------------
--
-- compile expressions, no compile state change necessary

cexpr	:: Expr -> Env -> Code
cexpr (IntConst i) _env
    = [Lconst i]

cexpr (BoolConst b) _env
    = [Lconst (fromEnum b)]

cexpr (Var id) env
    = [Load adr]
      where
      adr = fromJust (M.lookup id env)

cexpr (UnExpr UPlus opr1) env
    = cexpr opr1 env

cexpr (UnExpr UMinus opr1) env
    = cexpr (BinExpr Sub (IntConst 0) opr1) env

cexpr (UnExpr Neg opr1) env
    = cexpr (BinExpr Sub (IntConst 1) opr1) env

cexpr (BinExpr Eq opr1 opr2) env
    = cexpr (UnExpr Neg (BinExpr Neq opr1 opr2)) env

cexpr (BinExpr Neq opr1 opr2) env
    = cexpr (BinExpr Sub opr1 opr2) env

cexpr (BinExpr op opr1 opr2) env
    = cs1 ++ cs2 ++ [Compute (fromJust (lookup op mol))]
      where
      cs1 = cexpr opr1 env
      cs2 = cexpr opr2 env
      mol = [ (Add,  OpAdd)
	    , (Sub,  OpSub)
	    , (Mul,  OpMul)
	    , (Div,  OpDiv)
	    , (Mod,  OpMod)
	    ]

-- ------------------------------------------------------------
--
-- compile statements
-- the compile state consists of a variable address assoc list
-- a label count for generating new labels
-- and the so far generated code sequence

cstmt	:: Stmt -> CState -> CState
cstmt (Assign lhs rhs) state
    = appendCode (crhs ++ clhs) state'
      where
      crhs = cexpr rhs (vars state)
      clhs = [Store adr]
      (adr, state') = getAddr lhs state

cstmt (Stmts []) state
    = state

cstmt (Stmts (s:sl)) state
    = cstmt (Stmts sl) state'
      where
      state' = cstmt s state

cstmt (If cond thenp elsep) s0
    = s7
      where
      condCode = cexpr (UnExpr Neg cond) (vars s0)
      (l1, s1) = newLabel s0
      (l2, s2) = newLabel s1
      s3       = appendCode [Branch l1] s2
      s4       = cstmt thenp s3
      s5       = appendCode [ Goto l2
			    , Lab  l1] s4
      s6       = cstmt elsep s5
      s7       = appendCode [Lab l2] s6

cstmt (While cond body) s0
    = s5
      where
      condCode = cexpr cond (vars s0)
      (l1, s1) = newLabel s0
      (l2, s2) = newLabel s1
      s3       = appendCode [ Goto l1
			    , Lab  l2] s2
      s4       = cstmt body s3
      s5       = appendCode ([ Lab l1 ] ++ condCode ++ [Branch l2]) s4

-- ------------------------------------------------------------
--
-- tests

initState	= State M.empty

r0	= run p0
r1	= run p1
r2	= run p2


c0	= compile p0
c1	= compile p1
c2	= compile p2

-- ------------------------------------------------------------