%
% Copyright (C) 1997 Thomas Nordin and Alastair Reid
%

\begin{code}
module DIS
    ( DIS(..)
    , apply
    , ppDIS, ppDIS'
    , expandDIS, DISEnv
    , freeVarsOfDIS 
    , simplify
    ) where

import Casm( BaseTy(..), ppBaseTy )
import Name( Name ) 

import Pretty
import PrettyUtils( ppTuple, commaList, textline )

#if !defined(__HASKELL98__)
#define isAlphaNum isAlphanum
#endif
import Char( isAlphaNum, isLower )

\end{code}

I'd like to get rid of this definition

\begin{code}
-- The DIS table maps a user defined DIS to its definition.
type DISTable = [(Name, ([Name], DIS))]
\end{code}

%************************************************************************
%*                                                                      *
\subsection{DIS data structure}
%*                                                                      *
%************************************************************************

\begin{code}

data DIS 
  = Apply DIS [DIS]    -- args never empty
  | BaseDIS BaseTy
  | Constructor Name
  | Declare String DIS		-- declared DIS can only be a Var or an Exp
  | Exp String
  | Record Name [Name]
  | Tuple 
  | UserDIS Bool Name Name	-- bool is whether user functions are pure
  | Var Name
 deriving ( Show )

\end{code}

Always use this constructor to maintain the invariant that the
args part of an apply is non-empty.

\begin{code}

apply :: DIS -> [DIS] -> DIS
apply f [] = f
apply f as = Apply f as

\end{code}

%************************************************************************
%*                                                                      *
\subsection{Pretty Printing of DISs}
%*                                                                      *
%************************************************************************

\begin{code}

ppDIS :: DIS -> Doc
ppDIS = ppDIS' False

-- @ppDIS'@ Can either print the type casts or not.

ppDIS' :: Bool -> DIS -> Doc
ppDIS' showCasts dis = pp dis
 where

  pp (Apply Tuple ds)            = ppTuple (pps ds)
  pp (Apply (Record name fs) ds) = text name <+> braces (commaList fields)
   where
    fields = zipWith (\n d -> textline [n, "="] <+> d) fs (pps ds)
  pp (Apply d ds)                = parens (pp d <+> hsep (pps ds))
  pp (BaseDIS n)   		 = text "%%" <> text (show n)
  pp (Constructor nm)  		 = text nm
  pp (Declare s d)		 = text "declare" <+> quotes (text s) <+>
				   pp d <+> text "in"
  pp (Exp s)      		 = quotes (text s)
  pp (Record nm fs)    		 = text "<record>"
  pp Tuple             		 = text "()" -- unit
  pp (UserDIS True n1 n2) 	 = text ('<':n1++'/':n2++'>':[])
  pp (UserDIS False n1 n2) 	 = text ('<':'<':n1++'/':n2++'>':'>':[])
  pp (Var nm)      		 = text nm

  pps = map pp

\end{code}

%************************************************************************
%*                                                                      *
\subsection{Free Variables}
%*                                                                      *
%************************************************************************

\begin{code}

freeVarsOfDIS :: DIS -> [Name]
freeVarsOfDIS = free
 where
  free (Apply d ds)  = free d ++ concatMap free ds
  free (Var nm)      = [nm]
  free (Declare s d) = free d
  free _             = []

\end{code}

%************************************************************************
%*                                                                      *
\subsection{Expanding DISs}
%*                                                                      *
%************************************************************************

Expanding a DIS is rather like evaluating an expression: we walk over
the DIS with an environment replacing disnames and arguments with
values from the environment.

The result is a DIS in normal 

\begin{code}

type DISEnv = [(Name, ([Name], DIS))]
type ArgEnv = [(Name, DIS)]

expandDIS :: DISEnv -> DIS -> DIS
expandDIS denv d = expandDIS' denv [] d

expandDIS' :: DISEnv -> ArgEnv -> DIS -> DIS
expandDIS' denv aenv d = xp d
 where

  -- dis application
  xp (Apply f@(Var nm) ds)
    = case (lookup nm denv) of 
      Just (args, d)       -> if length args == length ds
                              then expandDIS' denv (zip args (xps ds)) d
                              else error ("Argument list mismatch while calling "
					 ++ nm
                                         ++ " in DIS "
                                         ++ show d
                                         )
      Nothing              -> Apply f (xps ds)

  xp (Apply d ds) = Apply (xp d) (xps ds)

  xp v@(Var nm) 
    = case (lookup nm aenv) of 
      Just d               -> d
      Nothing              -> v

  xp (Declare ctype v@(Var nm))
    = Declare (subst ctype) (case (lookup nm aenv) of
                             Just d   -> d
                             Nothing  -> v)

  xp (Declare ctype (Exp s))
    = Declare (subst ctype) (Exp (subst s))

  xp (Exp s)
    = Exp (subst s)

  xp (UserDIS p f t)
    = UserDIS p (subst f) (subst t)

  xp (BaseDIS (Foreign f))
    = BaseDIS (Foreign (subst f))

  -- everything else is already in normal form
  xp d = d

  xps = map xp

  -- substitute for anything of the form %[a-z][a-zA-Z0-9]*
  subst :: String -> String
  subst ('%':c:cs)
    | isLower c
    = case lookup nm aenv of
      Just (Exp c) -> c ++ subst rest
      Just (Var v) -> '%':v ++ subst rest
      Just d'      -> error ("Can't substitute " ++ show d' ++ " for " ++ nm ++ " in DIS " ++ show d)
      Nothing      -> error ("Unknown variable " ++ nm ++ " in DIS " ++ show d)
   where
    (cs0, rest) = span isAlphaNum cs
    nm = c:cs0
  subst ('%':'%':cs) = '%':'%': subst cs  -- escape code
  subst (c:cs)       = c : subst cs
  subst ""           = ""

\end{code}

%************************************************************************
%*                                                                      *
\subsection{Simplify DISs}
%*                                                                      *
%************************************************************************

Simplify a DIS by:
  *  pushing outer declarations down to leaves,
  *  overriding inner ones,
  *  removing declarations of literals (which have no effect),
  *  and where userDISs are applied to many args, converting args to a tuple

\begin{code}

simplify :: DIS -> DIS
simplify dis = simpl [] dis
  where
    simpl :: [(Name,DIS)] -> DIS -> DIS
    simpl env (Apply decl@(Declare cty (Var v)) [d]) =
      case lookup v env of
        Just _  -> simpl env d
        Nothing -> simpl ((v,decl):env) d
    simpl env (Apply (Declare cty (Exp v)) [d]) = simpl env d
    simpl env (Apply u@(UserDIS p f t) ds)
        | length ds > 1 = Apply u [Apply Tuple (map (simpl env) ds)]
    simpl env (Apply d ds) = Apply (simpl env d) (map (simpl env) ds)
    simpl env d@(Var "iO") = d
    simpl env (Var v) =
      case lookup v env of
        Just d  -> d
        Nothing -> error ("No C type decl for variable "++v++" in DIS:\n"
                          ++show dis)
    simpl env d@(Exp s) = inner env d s
    simpl env d = d

    inner env d [] = d
    inner env d ('%':c:cs)
      | isLower c
      = case lookup nm env of
        Just decl -> Apply decl [inner env d rest]
        Nothing   -> error ("No C type decl for variable "++nm++" in literal:\n"
                            ++show d)
      where
        (cs0, rest) = span isAlphaNum cs
        nm = c:cs0
    inner env d (c:cs) = inner env d cs
    

\end{code}

%************************************************************************
%*                                                                      *
\subsection{Example DISs}
%*                                                                      *
%************************************************************************

\begin{code}

dis1 = Apply (BaseDIS Int) [Declare "int" (Var "x")]
dis2 = Apply (BaseDIS Float) [Declare "float" (Var "y")]
dis3 = Apply Tuple [dis1,dis2]

disenv1 =
  [ ( "int",   (["x"], dis1) )
  , ( "float", (["y"], dis2) )
  ]

dis4 = Apply (Var "int") [Var "arg1"]
dis5 = expandDIS disenv1 dis4

\end{code}