Turned findMeta into a member of a FindMeta type-class

backends/GenerateC.hs

@@ -1504,9 +1504,13 @@ prefixComma cs = sequence_ [genComma >> c | c <- cs]
 cgenActuals :: [A.Formal] -> [A.Actual] -> CGen ()
 cgenActuals fs as
   = do when (length fs /= length as) $
-         dieP (findMeta (fs, as)) $ "Mismatch in numbers of parameters in backend: "
+         dieP m $ "Mismatch in numbers of parameters in backend: "
            ++ show (length fs) ++ " expected, but actually: " ++ show (length as)
        seqComma [call genActual f a | (f, a) <- zip fs as]
+  where
+    m | null fs && null as = emptyMeta
+      | null fs = findMeta $ head as
+      | otherwise = findMeta $ head fs
 
 cgenActual :: A.Formal -> A.Actual -> CGen ()
 cgenActual f a = seqComma $ realActuals f a id
@@ -1616,7 +1620,7 @@ cgenProcess p = case p of
   A.Assign m vs es -> call genAssign m vs es
   A.Input m c im -> call genInput c im
   A.Output m c ois ->
-    do Left ts <- protocolItems c
+    do Left ts <- protocolItems m c
        call genOutput c $ zip ts ois
   A.OutputCase m c t ois -> call genOutputCase c t ois
   A.Skip m -> tell ["/* skip */\n"]
@@ -1767,7 +1771,7 @@ cgenOutputCase c tag ois
           tell ["_"]
           genName proto
           tell [");"]
-          Right ps <- protocolItems c
+          Right ps <- protocolItems (findMeta c) c
           let ts = fromMaybe (error "genOutputCase unknown tag")
                      $ lookup tag ps
           call genOutput c $ zip ts ois

checks/CheckFramework.hs

@@ -408,7 +408,7 @@ applyAccum (accEmpty, accOneF, accJoinF) typeKeysGiven = applyAccum'
     applyAccum' :: (forall a. Data a => TransFuncAcc acc a) ->
            (forall b. Data b => (b, Route b A.AST) -> StateT acc (RestartT CheckOptM) b)
     applyAccum' f (x, route)
-      = do when (findMeta x /= emptyMeta) $ lift . lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta x}
+      = do when (findMeta_Data x /= emptyMeta) $ lift . lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta_Data x}
            (x', acc) <- lift $ flip runStateT accEmpty (gmapMForRoute typeSet (extF wrap) x)
            r <- f' (x', route, acc)
            modify (`accJoinF` acc)
@@ -427,7 +427,7 @@ applyAccum (accEmpty, accOneF, accJoinF) typeKeysGiven = applyAccum'
 applyTopDown :: TypeSet -> (forall a. Data a => TransFunc a) ->
              (forall b. Data b => (b, Route b A.AST) -> RestartT CheckOptM b)
 applyTopDown typeSet f (x, route)
-      = do when (findMeta x /= emptyMeta) $ lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta x}
+      = do when (findMeta_Data x /= emptyMeta) $ lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta_Data x}
            z <- f' (x, route)
            gmapMForRoute typeSet (\(y, route') -> applyTopDown typeSet f (y, route @-> route')) z
   where

checks/UsageCheckUtils.hs

@@ -39,7 +39,7 @@ import Types
 import Utils
 
 newtype Var = Var A.Variable
-  deriving (ASTTypeable, Data, Ord, Show, ShowOccam, ShowRain, Typeable)
+  deriving (ASTTypeable, Data, FindMeta, Ord, Show, ShowOccam, ShowRain, Typeable)
 
 instance Eq Var where
   a == b = EQ == compare a b

common/Types.hs

@@ -35,7 +35,7 @@ module Types
 
     , leastGeneralSharedTypeRain
     
-    , ASTTypeable(..)
+    , ASTTypeable(..), findMeta
   ) where
 
 import Control.Monad.State
@@ -337,13 +337,13 @@ returnTypesOfIntrinsic m s
 
 -- | Get the items in a channel's protocol (for typechecking).
 -- Returns Left if it's a simple protocol, Right if it's tagged.
-protocolItems :: (ASTTypeable a, Data a, CSMR m, Die m) => a -> m (Either [A.Type] [(A.Name, [A.Type])])
+protocolItems :: (ASTTypeable a, Data a, CSMR m, Die m) => Meta -> a -> m (Either [A.Type] [(A.Name, [A.Type])])
-protocolItems v
+protocolItems m v
     =  do chanT <- astTypeOf v
           t <- case chanT of
                  A.Chan _ t -> return t
                  A.ChanEnd _ _ t -> return t
-                 _ -> dieP (findMeta v) $ "Expected a channel variable, but this is of type: " ++ show chanT
+                 _ -> dieP m $ "Expected a channel variable, but this is of type: " ++ show chanT
           case t of
             A.UserProtocol proto ->
               do st <- specTypeOfName proto
@@ -481,8 +481,6 @@ isSafeConversion src dest = (src' == dest') || ((src' == A.Bool || isIntegerType
         ]
 
 
-
-
 -- | 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

data/CompState.hs

@@ -265,7 +265,7 @@ modifyName n f
 
 -- | Find the definition of a name.
 lookupName :: (CSMR m, Die m) => A.Name -> m A.NameDef
-lookupName n = lookupNameOrError n (dieP (findMeta n) $ "cannot find name " ++ A.nameName n)
+lookupName n = lookupNameOrError n (dieP (A.nameMeta n) $ "cannot find name " ++ A.nameName n)
 
 nameSource :: (CSMR m, Die m) => A.Name -> m A.NameSource
 nameSource n = lookupName n >>* A.ndNameSource
@@ -483,3 +483,70 @@ searchFile m filename
               case r of
                 Just h -> return (h, fn)
                 Nothing -> openOneOf all fns
+
+class FindMeta a where
+  findMeta :: a -> Meta
+
+instance FindMeta Meta where
+  findMeta = id
+
+instance FindMeta A.Name where
+  findMeta = A.nameMeta
+
+-- Should stop being lazy, and put these as pattern matches:
+findMeta_Data :: Data a => a -> Meta
+findMeta_Data = head . listify (const True)
+
+instance FindMeta A.Expression where
+  findMeta = findMeta_Data
+
+instance FindMeta A.LiteralRepr where
+  findMeta = findMeta_Data
+
+instance FindMeta A.Subscript where
+  findMeta = findMeta_Data
+
+instance FindMeta A.Process where
+  findMeta = findMeta_Data
+
+instance FindMeta A.Variable where
+  findMeta (A.Variable m _) = m
+  findMeta (A.SubscriptedVariable m _ _) = m
+  findMeta (A.DirectedVariable m _ _) = m
+  findMeta (A.DerefVariable m _) = m
+  findMeta (A.VariableSizes m _) = m
+
+instance FindMeta A.SpecType where
+  findMeta = findMeta_Data
+
+instance FindMeta A.ExpressionList where
+  findMeta = findMeta_Data
+
+instance FindMeta A.Alternative where
+  findMeta = findMeta_Data
+
+instance FindMeta A.InputMode where
+  findMeta = findMeta_Data
+
+instance Data a => FindMeta (A.Structured a) where
+  findMeta = findMeta_Data
+
+instance FindMeta A.Actual where
+  findMeta (A.ActualVariable v) = findMeta v
+  findMeta (A.ActualExpression e) = findMeta e
+  findMeta (A.ActualClaim v) = findMeta v
+  findMeta (A.ActualChannelArray []) = emptyMeta
+  findMeta (A.ActualChannelArray (v:_)) = findMeta v
+
+instance FindMeta A.Replicator where
+  findMeta (A.For m _ _ _) = m
+  findMeta (A.ForEach m _) = m
+
+instance FindMeta A.Specification where
+  findMeta (A.Specification m _ _) = m
+
+instance FindMeta A.Formal where
+  findMeta (A.Formal _ _ n) = findMeta n
+
+instance FindMeta A.NameDef where
+  findMeta = A.ndMeta

data/Metadata.hs

@@ -84,10 +84,3 @@ unpackMeta s
     metaRE = mkRegex "^(.*)//pos:([0-9]*):([0-9]*):(.*)//(.*)$"
     getInt s = case readDec s of [(v, "")] -> v
 
--- | Find the first Meta value in some part of the AST.
--- Return 'emptyMeta' if it couldn't find one.
-findMeta :: Data t => t -> Meta
-findMeta e
-    = case listify (const True :: Meta -> Bool) e of
-        (m:_) -> m
-        [] -> emptyMeta

flow/FlowGraph.hs

@@ -51,6 +51,7 @@ import Data.Graph.Inductive hiding (run)
 import Data.Maybe
 
 import qualified AST as A
+import CompState
 import GenericUtils
 import Metadata
 import FlowUtils

frontends/OccamTypes.hs

@@ -812,7 +812,7 @@ inferTypes = occamOnlyPass "Infer types"
 
     doInputMode :: A.Variable -> Transform A.InputMode
     doInputMode v (A.InputSimple m iis)
-      = do ts <- protocolItems v >>* either id (const [])
+      = do ts <- protocolItems m v >>* either id (const [])
            iis' <- sequence [inTypeContext (Just t) $ recurse ii
                             | (t, ii) <- zip ts iis]
            return $ A.InputSimple m iis'
@@ -825,7 +825,7 @@ inferTypes = occamOnlyPass "Infer types"
     doVariant (A.Variant m n iis p)
       = do ctx <- getTypeContext
            ets <- case ctx of
-             Just x -> protocolItems x
+             Just x -> protocolItems m x
              Nothing -> dieP m "Could not deduce protocol"
            case ets of
              Left {} -> dieP m "Simple protocol expected during input CASE"

frontends/RainTypes.hs

@@ -39,6 +39,13 @@ import TypeUnification
 import UnifyType
 import Utils
 
+-- This is a bit of a hack for this file:
+data M = M Meta A.Type deriving (Typeable, Data)
+instance ASTTypeable M where
+  astTypeOf (M m t) = return t
+instance FindMeta M where
+  findMeta (M m t) = m
+
 data RainTypeState = RainTypeState {
     csUnifyLookup :: Map.Map UnifyIndex UnifyValue,
     csUnifyPairs :: [(UnifyValue, UnifyValue)]
@@ -102,7 +109,7 @@ typeToTypeExp _ (A.UnknownNumLitType m id n)
        return v
 typeToTypeExp m t = return $ OperType m (show t) (const t) []
 
-markUnify :: (ASTTypeable a, ASTTypeable b, Data a, Data b) => a -> b -> RainTypeM ()
+markUnify :: (ASTTypeable a, ASTTypeable b, FindMeta a, FindMeta b, Data a, Data b) => a -> b -> RainTypeM ()
 markUnify x y
   = do tx <- astTypeOf x
        ty <- astTypeOf y
@@ -167,8 +174,8 @@ markReplicators :: RainTypePassType
 markReplicators = checkDepthM mark
   where
     mark :: RainTypeCheck A.Specification
-    mark (A.Specification _ n (A.Rep _ (A.ForEach _m e)))
+    mark (A.Specification m n (A.Rep _ (A.ForEach _m e)))
-      = astTypeOf n >>= \t -> markUnify (A.List t) e
+      = astTypeOf n >>= \t -> markUnify (M m $ A.List t) e
     mark _ = return ()
 
 -- | Folds all constants.
@@ -222,8 +229,8 @@ markExpressionTypes = checkDepthM checkExpression
     checkExpression :: RainTypeCheck A.Expression
 --    checkExpression (A.Dyadic _ _ lhs rhs)
 --      = markUnify lhs rhs
-    checkExpression (A.Literal _ t (A.ArrayListLiteral _ es))
+    checkExpression (A.Literal m t (A.ArrayListLiteral m' es))
-      = checkListElems (markUnify t) es
+      = checkListElems (markUnify (M m t) . M m') es
     checkExpression _ = return ()
 
     checkListElems :: RainTypeCheck A.Type -> RainTypeCheck (A.Structured A.Expression)
@@ -247,7 +254,7 @@ markAssignmentTypes = checkDepthM checkAssignment
              A.Variable _ n ->
                do st <- specTypeOfName n
                   case st of
-                    A.Function _ _ [t] _ _ -> markUnify t e
+                    A.Function m _ [t] _ _ -> markUnify (M m t) e
                     _ -> markUnify v e
              _ -> markUnify v e
     checkAssignment (A.Assign m _ _) = dieInternal (Just m,"Rain checker found occam-style assignment")
@@ -259,12 +266,12 @@ markConditionalTypes = checkDepthM2 checkWhile checkIf
   where
     checkWhile :: RainTypeCheck A.Process
     checkWhile w@(A.While m exp _)
-      = markUnify exp A.Bool
+      = markUnify exp (M m A.Bool)
     checkWhile _ = return ()
     
     checkIf :: RainTypeCheck A.Choice
     checkIf c@(A.Choice m exp _)
-      = markUnify exp A.Bool
+      = markUnify exp (M m A.Bool)
 
 -- | Marks types in poison statements
 markPoisonTypes :: RainTypePassType
@@ -273,7 +280,7 @@ markPoisonTypes = checkDepthM checkPoison
     checkPoison :: RainTypeCheck A.Process
     checkPoison (A.InjectPoison m ch)
       = do u <- lift getUniqueIdentifer
-           markUnify ch $ A.UnknownVarType (A.TypeRequirements True) $ Right (m, u)
+           markUnify ch (M m $ A.UnknownVarType (A.TypeRequirements True) $ Right (m, u))
     checkPoison _ = return ()
 
 -- | Checks the types in inputs and outputs, including inputs in alts
@@ -282,12 +289,12 @@ markCommTypes = checkDepthM2 checkInputOutput checkAltInput
   where
     checkInput :: A.Variable -> A.Variable -> Meta -> a -> RainTypeM ()
     checkInput chanVar destVar m p
-      = astTypeOf destVar >>= markUnify chanVar . A.ChanEnd A.DirInput A.Unshared
+      = astTypeOf destVar >>= markUnify chanVar . M (findMeta destVar) . A.ChanEnd A.DirInput A.Unshared
 
     checkWait :: RainTypeCheck A.InputMode
-    checkWait (A.InputTimerFor m exp) = markUnify A.Time exp
+    checkWait (A.InputTimerFor m exp) = markUnify (M m A.Time) exp
-    checkWait (A.InputTimerAfter m exp) = markUnify A.Time exp
+    checkWait (A.InputTimerAfter m exp) = markUnify (M m A.Time) exp
-    checkWait (A.InputTimerRead m (A.InVariable _ v)) = markUnify A.Time v
+    checkWait (A.InputTimerRead m (A.InVariable m' v)) = markUnify (M m A.Time) v
     checkWait _ = return ()
 
     checkInputOutput :: RainTypeCheck A.Process
@@ -297,7 +304,7 @@ markCommTypes = checkDepthM2 checkInputOutput checkAltInput
     checkInputOutput (A.Input _ _ im@(A.InputTimerAfter {})) = checkWait im
     checkInputOutput (A.Input _ _ im@(A.InputTimerRead {})) = checkWait im
     checkInputOutput p@(A.Output m chanVar [A.OutExpression m' srcExp])
-      = astTypeOf srcExp >>= markUnify chanVar . A.ChanEnd A.DirOutput A.Unshared
+      = astTypeOf srcExp >>= markUnify chanVar . M m' . A.ChanEnd A.DirOutput A.Unshared
     checkInputOutput _ = return ()
 
     checkAltInput :: RainTypeCheck A.Alternative

frontends/TypeUnification.hs

@@ -27,6 +27,7 @@ import Data.Maybe
 import Data.IORef
 
 import qualified AST as A
+import CompState
 import Errors
 import Metadata
 import Pass
@@ -34,6 +35,13 @@ import ShowCode
 import UnifyType
 import Utils
 
+instance Typeable a => FindMeta (TypeExp a) where
+  findMeta (MutVar m _) = m
+  findMeta (GenVar m _) = m
+  findMeta (NumLit m _) = m
+  findMeta (OperType m  _ _ _) = m
+
+
 foldCon :: ([A.Type] -> A.Type) -> [Either String A.Type] -> Either String A.Type
 foldCon con es = case splitEither es of
   ([],ts) -> Right $ con ts
@@ -210,7 +218,7 @@ unifyType te1 te2
   where
     unifyArgs (x:xs) (y:ys) = unifyType x y >> unifyArgs xs ys
     unifyArgs [] [] = return ()
-    unifyArgs xs ys = dieP (findMeta (xs,ys)) "different lengths"
+    unifyArgs xs ys = dieP (findMeta $ head (xs ++ ys)) "different lengths"
 
 instantiate :: Typeable a => [TypeExp a] -> TypeExp a -> TypeExp a
 instantiate ts x = case x of

frontends/UnifyType.hs

@@ -33,3 +33,4 @@ data Typeable a => TypeExp a
  | NumLit Meta (IORef (Either [(Meta, Integer)] A.Type))
  | OperType Meta String ([A.Type] -> A.Type) [ TypeExp a ]
  deriving (Typeable, Data)
+

pass/Properties.hs

@@ -128,9 +128,14 @@ getDeclaredNames = everything (++) ([] `mkQ` find)
     find (A.Specification _ n (A.Declaration {})) = [n]
     find _ = []
 
-checkNull :: (Data a, Die m) => String -> [a] -> m ()
+checkNull :: (Data a, FindMeta a, Die m) => String -> [a] -> m ()
 checkNull _ [] = return ()
-checkNull s xs = dieP (findMeta xs) $ "Property check " ++ show s ++ " failed: " ++ pshow xs
+checkNull s xs = dieP (findMeta $ head xs) $ "Property check " ++ show s ++ " failed: " ++ pshow xs
+
+checkNull' :: (Data a, Die m) => String -> [a] -> m ()
+checkNull' _ [] = return ()
+checkNull' s xs = dieP emptyMeta $ "Property check " ++ show s ++ " failed: " ++ pshow xs
+
 
 isNonceOrUnique :: String -> Bool
 isNonceOrUnique nm = isJust $ matchRegex (mkRegex ".*_[a-z][0-9]+$") nm
@@ -141,7 +146,7 @@ declaredNamesResolved = Property "declaredNamesResolved" $
 
 noInt :: Property
 noInt = Property "noInt" $
-  checkNull "noInt" . listify (== A.Int)
+  checkNull' "noInt" . listify (== A.Int)
 
 declarationTypesRecorded :: Property
 declarationTypesRecorded = Property "declarationTypesRecorded" $ \t ->
@@ -232,7 +237,7 @@ rainParDeclarationsPulledUp = Property "rainParDeclarationsPulledUp" checkTODO
 
 inferredTypesRecorded :: Property
 inferredTypesRecorded = Property "inferredTypesRecorded" $
-                          checkNull "inferredTypesRecorded" . listify findInfer
+                          checkNull' "inferredTypesRecorded" . listify findInfer
   where
     findInfer :: A.Type -> Bool
     findInfer A.Infer = True
@@ -247,11 +252,11 @@ findUDT _ = False
 
 typesResolvedInAST :: Property
 typesResolvedInAST = Property "typesResolvedInAST" $
-  checkNull "typesResolvedInAST" . listify findUDT
+  checkNull' "typesResolvedInAST" . listify findUDT
 
 typesResolvedInState :: Property
 typesResolvedInState = Property "typesResolvedInState" $
-  \t -> checkNull "typesResolvedInState" . listify findUDT =<< getCompState
+  \t -> checkNull' "typesResolvedInState" . listify findUDT =<< getCompState
 
 checkAllExprVariable :: Die m => [A.Expression] -> m ()
 checkAllExprVariable = mapM_ check
@@ -407,12 +412,12 @@ listsGivenType = Property "listsGivenType" checkTODO
 initialRemoved :: Property
 initialRemoved
     = Property "initialRemoved" $
-        checkNull "initialRemoved" . listify (== A.InitialAbbrev)
+        checkNull' "initialRemoved" . listify (== A.InitialAbbrev)
 
 resultRemoved :: Property
 resultRemoved
     = Property "resultRemoved" $
-        checkNull "resultRemoved" . listify (== A.ResultAbbrev)
+        checkNull' "resultRemoved" . listify (== A.ResultAbbrev)
 
 directionsRemoved :: Property
 directionsRemoved

transformations/SimplifyComms.hs

@@ -158,7 +158,7 @@ transformInputCase = pass "Transform ? CASE statements/guards into plain CASE"
     doStructuredV chanVar = transformOnly transform
       where
         transform m (A.Variant m' n iis p)
-            =  do (Right items) <- protocolItems chanVar
+            =  do (Right items) <- protocolItems m' chanVar
                   let (Just idx) = elemIndex n (fst $ unzip items)
                   return $ A.Only m $ A.Option m' [makeConstant m' idx] $
                     if length iis == 0