Turned findMeta into a member of a FindMeta type-class

This commit is contained in:
Neil Brown 2009-04-09 11:13:37 +00:00
parent 998cf1c005
commit 229f2197af
13 changed files with 130 additions and 46 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 v
protocolItems :: (ASTTypeable a, Data a, CSMR m, Die m) => Meta -> a -> m (Either [A.Type] [(A.Name, [A.Type])])
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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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"

View File

@ -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)))
= astTypeOf n >>= \t -> markUnify (A.List t) e
mark (A.Specification m n (A.Rep _ (A.ForEach _m 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))
= checkListElems (markUnify t) es
checkExpression (A.Literal m t (A.ArrayListLiteral m' 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.InputTimerAfter m exp) = markUnify A.Time exp
checkWait (A.InputTimerRead m (A.InVariable _ v)) = markUnify A.Time v
checkWait (A.InputTimerFor m exp) = markUnify (M m A.Time) exp
checkWait (A.InputTimerAfter m exp) = markUnify (M m A.Time) exp
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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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