From a454aa78f87589c93ca038a0b8fdfb23aa6633fa Mon Sep 17 00:00:00 2001
From: Neil Brown <neil@twistedsquare.com>
Date: Sat, 15 Sep 2007 18:57:02 +0000
Subject: [PATCH] Rain: implemented the checkExpression function and got it
 passing the tests so far

---
 common/Types.hs        | 63 +++++++++++++++++++++++++++++++++++++++++-
 common/Utils.hs        |  5 ++++
 frontends/RainTypes.hs | 16 ++++++++++-
 3 files changed, 82 insertions(+), 2 deletions(-)

diff --git a/common/Types.hs b/common/Types.hs
index f813fa5..1763d8b 100644
--- a/common/Types.hs
+++ b/common/Types.hs
@@ -28,6 +28,8 @@ module Types
     , addDimensions, removeFixedDimensions, trivialSubscriptType, subscriptType, unsubscriptType
     , recordFields, protocolItems
 
+	, leastGeneralSharedTypeRain
+
     , findMeta
 
   ) where
@@ -37,7 +39,8 @@ import Control.Monad.State
 import Data.Generics
 import qualified Data.Map as Map
 import Data.Maybe
-import Debug.Trace
+import Data.List
+import Data.Ord
 
 import qualified AST as A
 import CompState
@@ -45,6 +48,7 @@ import Errors
 import EvalLiterals
 import Intrinsics
 import Metadata
+import Utils
 
 -- | Gets the 'A.SpecType' for a given 'A.Name' from the recorded types in the 'CompState'.  Dies with an error if the name is unknown.
 specTypeOfName :: (CSM m, Die m) => A.Name -> m A.SpecType
@@ -393,6 +397,63 @@ isSafeConversion src dest = (src' == dest') || ((src' == A.Bool || isIntegerType
           ,(A.UInt64, A.UInt32)
         ]
 
+
+
+
+-- | Works out the least-general type that all given types can be upcast to.  Does not work with A.Int (as this function is expected only to be used by Rain)
+-- As you would expect from the name, this function specifically follows the conversion rules for Rain.
+leastGeneralSharedTypeRain :: [A.Type] -> Maybe A.Type
+leastGeneralSharedTypeRain [] = Nothing
+leastGeneralSharedTypeRain [t] = Just t
+leastGeneralSharedTypeRain list@(t:ts)
+  = if (all ((==) t) ts) then Just t else
+      if (all isIntegerType list) then findInt list
+      else Nothing
+  where
+    findInt :: [A.Type] -> Maybe A.Type
+    findInt list = if null candidates
+                     then Nothing
+                     else Just $ snd $ maximumBy (comparing fst) candidates
+                   where
+                     candidates = if (all unsignedInt list) then (zip (map intSize list) list) else (allJustElseEmpty $ map findIntSigned list)
+
+    signedInt :: A.Type -> Bool
+    signedInt = not . unsignedInt
+
+    unsignedInt :: A.Type -> Bool
+    unsignedInt A.Byte = True
+    unsignedInt A.UInt16 = True
+    unsignedInt A.UInt32 = True
+    unsignedInt A.UInt64 = True
+    unsignedInt _ = False
+
+    intSize :: A.Type -> Int
+    intSize A.Byte = 1
+    intSize A.UInt16 = 2
+    intSize A.UInt32 = 4
+    intSize A.UInt64 = 8
+    intSize A.Int8 = 1
+    intSize A.Int16 = 2
+    intSize A.Int32 = 4
+    intSize A.Int64 = 8
+    intSize _ = 0 --should never happen
+
+    --If all the items in the list are Just x, returns a list of them all.
+    --If one (or more items) is Nothing, returns an empty list.
+    allJustElseEmpty :: [Maybe a] -> [a]
+    allJustElseEmpty ms = if (any isNothing ms) then [] else catMaybes ms
+
+    --For each item in the list, get an ordered list of types we can cast to.
+    findIntSigned :: A.Type -> Maybe (Int,A.Type)
+    findIntSigned t = if (signedInt t)
+                        then Just (intSize t,t)
+                        --if it's unsigned, we need to cast it up by one type, assuming it's not already the biggest size
+                        else transformMaybe (\x -> (intSize x,x)) (case t of
+                               A.Byte -> Just A.Int16
+                               A.UInt16 -> Just A.Int32
+                               A.UInt32 -> Just A.Int64
+                               A.UInt64 -> Nothing)
+
 --{{{ classes of types
 -- | Scalar integer types.
 isIntegerType :: A.Type -> Bool
diff --git a/common/Utils.hs b/common/Utils.hs
index 2d45835..11a3b4a 100644
--- a/common/Utils.hs
+++ b/common/Utils.hs
@@ -62,6 +62,11 @@ transformEither funcLeft funcRight x = case x of
   Left l -> Left (funcLeft l)
   Right r -> Right (funcRight r)
 
+-- | Transforms between two 'Maybe' types using a function:
+transformMaybe :: (a -> b) -> Maybe a -> Maybe b
+transformMaybe _ Nothing = Nothing
+transformMaybe f (Just x) = Just (f x)
+
 -- | Try an IO operation, returning `Nothing` if it fails.
 maybeIO :: IO a -> IO (Maybe a)
 maybeIO op = catch (op >>= (return . Just)) (\e -> return Nothing)
diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs
index f1dd829..abe4322 100644
--- a/frontends/RainTypes.hs
+++ b/frontends/RainTypes.hs
@@ -96,5 +96,19 @@ checkExpressionTypes :: Data t => t -> PassM t
 checkExpressionTypes = everywhereASTM checkExpression
   where
     checkExpression :: A.Expression -> PassM A.Expression
-    checkExpression = return
+    checkExpression e@(A.Dyadic m op lhs rhs)
+      = do tlhs <- typeOfExpression lhs
+           trhs <- typeOfExpression rhs
+           if (tlhs == trhs)
+             then return e
+             else case (leastGeneralSharedTypeRain [tlhs,trhs]) of
+                    Nothing -> dieP m $ "Cannot find a suitable type to convert expression to, types are: " ++ show tlhs ++ " and " ++ show trhs
+                    Just t -> return $ A.Dyadic m op (convert t tlhs lhs) (convert t trhs rhs)
+    checkExpression e = return e
+
+    convert :: A.Type -> A.Type -> A.Expression -> A.Expression
+    convert dest src e = if (dest == src)
+                           then e
+                           else A.Conversion (findMeta e) A.DefaultConversion dest e
+