--  The HiPar Toolkit: test routines for attribute management
--
--  Author : Manuel M.T. Chakravarty
--  Created: 9 November 1995
--
--  Version $Revision: 1.1.1.1 $ from $Date: 2004/11/13 16:42:44 $
--
--  Copyright (C) [1995..1998] Manuel M. T. Chakravarty
--
--  THIS FILE IS DISTRIBUTED UNDER THE TERMS OF THE GNU PUBLIC LICENCE
--  NO WARRANTY WHATSOEVER IS PROVIDED
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  This module provides code used to test the `Attributes' module.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 1.4
--
--- TODO ----------------------------------------------------------------------
--

module Main
where

import Common
import Errors
import UNames
import NameSpaces
import Idents
import State
import Attributes


main :: IO ()
main  = run ("", "", "") () (
          putStrCIO "HiPar attribute test program\n"            +>
          putStrCIO "============================\n\n"          +>
          getNameSupply                                         +>= \supply ->
          testAttrTables (names supply)                         +>
--
-- the following tests must lead to an internal error (violation of an
-- assertion) when any of them is executed
--
          getNameSupply                                         +>= \supply ->
          -- access with uninit. attr.s
--        checkAttrTableErr1 (names supply)                     +>
          -- set already set attr.
--        checkAttrTableErr2 (names supply)                     +>
          -- write frozen table
--        checkAttrTableErr3 (names supply)                     +>
          -- freeze frozen table
--        checkAttrTableErr4 (names supply)                     +>
          testAttrWithMonad
        )

-- test the attribute table functions
-- ----------------------------------

data T = A | B | NoT | DontCareT
       deriving (Eq, Show)

instance Attr T where

  undef = NoT

  isUndef NoT = True
  isUndef _   = False

  dontCare = DontCareT

  isDontCare DontCareT = True
  isDontCare _         = False

at :: AttrTable T
at  = newAttrTable "test table"

testAttrTables    :: [Name] -> PreCST e s ()
testAttrTables ns  =
  putStrCIO "Checking the functions for attribute tables...\n"          +>
  let
    n10 : n13 : _ = ns
    aid10         = newAttrs nopos n10
    aid13         = newAttrs nopos n13
  in
  let
    ok1 = isUndef (at `getAttr` aid10)
    at2 = setAttr at aid10 A
    ok2 = (at2 `getAttr` aid10) == A
    at3 = updAttr at aid10 B
    ok3 = (at3 `getAttr` aid10) == B
    at4 = freezeAttrTable at3
    ok4 = (at4 `getAttr` aid10) == B
    ok5 = isUndef (at4 `getAttr` aid13)
    at6 = softenAttrTable at4
    ok6 = (at6 `getAttr` aid10) == B
    at7 = setAttr at6 aid13 A
    ok7 = (at7 `getAttr` aid13) == A
    ok8 = (at7 `getAttr` aid10) == B
  in
  if ok1 && ok2 && ok3 && ok4 && ok5 && ok6 && ok7 && ok8
  then
    putStrCIO "...they are ok.\n"               
  else
    putStrCIO "...ERROR DETECTED: test(s) "                +>
    putIfNotOk "ok1" ok1                                   +>
    putIfNotOk "ok2" ok2                                   +>
    putIfNotOk "ok3" ok3                                   +>
    putIfNotOk "ok4" ok4                                   +>
    putIfNotOk "ok5" ok5                                   +>
    putIfNotOk "ok6" ok6                                   +>
    putIfNotOk "ok7" ok7                                   +>
    putIfNotOk "ok8" ok8                                   +>
    putStrCIO " failed.\n"
  where
    putIfNotOk name True  = yield ()
    putIfNotOk name False = putStrCIO name +> putStrCIO " "


-- tests that must lead to an internal error (violate some assertion)
--

checkAttrTableErr1 _ = putStrCIO (show (
                          at `getAttr` (newAttrsOnlyPos nopos)
                        ))
checkAttrTableErr2 ns = let
                          aid10 = newAttrs nopos (head ns)
                        in
                        putStrCIO (show (
                          setAttr (setAttr at aid10 A) aid10 A `getAttr` aid10
                        ))
checkAttrTableErr3 ns = let
                          aid10 = newAttrs nopos (head ns)
                        in
                        putStrCIO (show (
                          setAttr (freezeAttrTable at) aid10 A `getAttr` aid10
                        ))
checkAttrTableErr4 ns = let
                          aid10 = newAttrs nopos (head ns)
                        in
                        putStrCIO (show (
                          freezeAttrTable (freezeAttrTable at) `getAttr` aid10
                        ))


-- test attributes with monad
-- --------------------------

type VName = Ident

data Exp = Const Int
         | Var   VName
         | Add   Exp Exp
         | Mul   Exp Exp
         | Let   [Bd] Exp
--       deriving (Show)

data Bd  = Bd VName Exp
--       deriving (Show)

data A a = Undef
         | DontCare
         | Value a

instance Attr (A a) where
  undef    = Undef
  dontCare = DontCare

  isUndef Undef = True
  isUndef _     = False

  isDontCare DontCare = True
  isDontCare _        = False

value           :: A a -> a
value (Value x)  = x

type VarObj    = Bd
type VarsTable = AttrTable (A VarObj)
type MyState   = ([Name], VarsTable, NameSpace VarObj)
type MyCST a   = PreCST () MyState a

-- monad operation for the creation of attribute identifiers
--
enableAttrs    :: Ident -> MyCST Ident
enableAttrs id  = transCST enable
                  where
                    enable (n:ns, vt, env) =
                      let
                        id' = lexemeToIdent (posOf id) (identToLexeme id) n
                      in
                        ((ns, vt, env), id')

-- monad operations for the attribute table
--

getDefOf    :: Ident -> MyCST Bd
getDefOf id  = readCST (\(_, vt, _) -> value ((getAttr vt . getIdentAttrs) id))

becomesDef       :: Ident -> Bd -> MyCST ()
becomesDef id bd  = transCST (\(ais, vt, env)
                              -> ((ais,
                                   setAttr vt (getIdentAttrs id) (Value bd),
                                   env),
                                  ()))

-- monad operations for environment management
--

enter :: MyCST ()
enter  = transCST (\(ais, vt, env) -> ((ais, vt, enterNewRange env), ()))

leave :: MyCST ()
leave  = transCST (\(ais, vt, env) -> ((ais, vt, fst (leaveRange env)), ()))

define         :: VName -> VarObj -> MyCST ()
define name vo  = transCST (\(ais, vt, env)
                            -> let
                                 (env', clash) = defLocal env name vo
                               in
                                 case clash of
                                   Nothing -> ((ais, vt, env'), ())
                                   Just _  -> interr "Main: Identifier\
                                                     \ declared twice!")

findName      :: VName -> MyCST (Maybe VarObj)
findName name  = readCST (\(ais, vt, env) -> find env name)

-- start a monad-based traversal
--
runMyCST   :: MyCST a -> PreCST () s' a
runMyCST m  = do
                supply <- getNameSupply
                runCST m (names supply, vars, nameSpace)
              where
                vars = newAttrTable "variable objects"

-- simple expression
--
expr :: Exp
expr  = Let [Bd (onlyPosIdent nopos "x") (Const 1),
             Bd (onlyPosIdent nopos "y") (Mul (Const 2) (Const 3))
            ]
            (Add (Var (onlyPosIdent nopos "x"))
                 (Var (onlyPosIdent nopos "y")))

-- attribute an expression, i.e., create the attribute identifiers and perform
-- the name analysis
--
attr              :: Exp -> MyCST Exp
attr (Const v)     = yield (Const v)
attr (Var   n)     = enableAttrs n              +>= \n' ->
                     findName n'                +>= \maybeobj ->
                     case maybeobj of
                       Nothing  -> interr "Main: Undeclared identifier!"
                       Just obj -> n' `becomesDef` obj  +>
                                   yield (Var n')
attr (Add   e1 e2) = attr e1                    +>= \e1' ->
                     attr e2                    +>= \e2' ->
                     yield (Add e1' e2')
attr (Mul   e1 e2) = attr e1                    +>= \e1' ->
                     attr e2                    +>= \e2' ->
                     yield (Mul e1' e2')
attr (Let   bds e) = mapM attrBd bds            +>= \bds' ->
                     enter                      +>
                       mapM def bds'            +>= \_   ->
                       attr e                   +>= \e'  ->
                     leave                      +>
                     yield (Let bds' e')
                     where
                       def bd@(Bd name _) = define name bd

attrBd             :: Bd -> MyCST Bd
attrBd (Bd name e)  = attr e                     +>= \e' ->
                      enableAttrs name           +>= \name' ->
                      let
                        bd = Bd name' e'
                      in
                      name' `becomesDef` bd +>
                      yield bd

-- yields the value of an attributed expression
--
eval              :: Exp -> MyCST Int
eval (Const v    ) = yield v
eval (Var   n    ) = getDefOf n         +>= \(Bd _ e) ->
                     eval e
eval (Add   e1 e2) = eval e1            +>= \v1 ->
                     eval e2            +>= \v2 ->
                     yield (v1 + v2)
eval (Mul   e1 e2) = eval e1            +>= \v1 ->
                     eval e2            +>= \v2 ->
                     yield (v1 * v2)
eval (Let   bds e) = eval e

testAttrWithMonad :: PreCST () s ()
testAttrWithMonad  = putStrCIO "Attributing simple expression...\n"  +>
                     runMyCST (
                       attr expr                                     +>= \e' ->
                       putStrCIO "...evaluating attributed\
                                 \ expression...\n"                  +>
                       eval e'
                     )                                               +>= \v ->
                     putStrCIO ("...result is " ++ show v ++ " (should be 7).\n")
