Turned findMeta into a member of a FindMeta type-class
This commit is contained in:
parent
998cf1c005
commit
229f2197af
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user