| Line No. | Rev | Author | Line |
|---|---|---|---|
| 1 | 1 | paulosilva | |
| 2 | {-# LANGUAGE FlexibleContexts #-} | ||
| 3 | {-# OPTIONS_GHC -Wall #-} | ||
| 4 | |||
| 5 | ------------------------------------------------------------------------------- | ||
| 6 | |||
| 7 | {- | | ||
| 8 | Module : Language.R.Verify | ||
| 9 | Description : Validation of the uniqueness of definitions and the existence | ||
| 10 | of references. | ||
| 11 | Copyright : (c) Paulo Silva | ||
| 12 | License : LGPL | ||
| 13 | |||
| 14 | Maintainer : paufil@di.uminho.pt | ||
| 15 | Stability : experimental | ||
| 16 | Portability : portable | ||
| 17 | |||
| 18 | -} | ||
| 19 | |||
| 20 | ------------------------------------------------------------------------------- | ||
| 21 | |||
| 22 | module Language.R.Verify ( | ||
| 23 | verify, | ||
| 24 | getDefs, | ||
| 25 | replaceDefs, | ||
| 26 | Env'(..), | ||
| 27 | ExtEnv, | ||
| 28 | reps | ||
| 29 | ) where | ||
| 30 | |||
| 31 | ------------------------------------------------------------------------------- | ||
| 32 | |||
| 33 | import Control.GalcError | ||
| 34 | import Control.Monad.Error | ||
| 35 | import Control.Monad.Reader | ||
| 36 | import Control.Monad.State | ||
| 37 | import Data.Env | ||
| 38 | import Data.List | ||
| 39 | import Language.R.Syntax | ||
| 40 | import Language.R.SyntaxADT | ||
| 41 | |||
| 42 | ------------------------------------------------------------------------------- | ||
| 43 | |||
| 44 | -- ======== | ||
| 45 | type ExtEnv = Env RType | ||
| 46 | type IntEnv = Env S | ||
| 47 | data Env' = Env' {internal :: IntEnv, external :: ExtEnv } | ||
| 48 | |||
| 49 | |||
| 50 | reps :: Ord a => [a] -> [a] | ||
| 51 | reps = map head . filter ((>1) . length ) . group . sort | ||
| 52 | -- ======== | ||
| 53 | ------------------------------------------------------------------------------- | ||
| 54 | |||
| 55 | verify :: MonadError GalcError m => ExtEnv -> S -> m S | ||
| 56 | verify extEnv s = let | ||
| 57 | env = getDefs s | ||
| 58 | ids = reps $ indexes extEnv ++ map fst env | ||
| 59 | in if null ids | ||
| 60 | then runReaderT (replaceDefs s) $ Env' {internal = fromListEnv env, | ||
| 61 | external = extEnv } | ||
| 62 | else throwError $ MultiDefError . concatMap ((++"\n") . show) $ ids | ||
| 63 | |||
| 64 | ------------------------------------------------------------------------------- | ||
| 65 | |||
| 66 | getDefs :: S -> [(String, S)] | ||
| 67 | getDefs d@(DefS _ n _) = [(n,d)] | ||
| 68 | getDefs g@(GDefS _ n f1 f2 o1 o2) = | ||
| 69 | (n,g) : getDefs f1 ++ getDefs f2 ++ getDefs o1 ++ getDefs o2 | ||
| 70 | getDefs (MeetS _ s1 s2) = getDefs s1 ++ getDefs s2 | ||
| 71 | getDefs (JoinS _ s1 s2) = getDefs s1 ++ getDefs s2 | ||
| 72 | getDefs (ConvS _ s) = getDefs s | ||
| 73 | getDefs (CompS _ s1 s2) = getDefs s1 ++ getDefs s2 | ||
| 74 | getDefs (SplitS _ s1 s2) = getDefs s1 ++ getDefs s2 | ||
| 75 | getDefs (OrdS _ s) = getDefs s | ||
| 76 | getDefs (FunS _ s) = getDefs s | ||
| 77 | getDefs (LeftsecS _ s1 s2) = getDefs s1 ++ getDefs s2 | ||
| 78 | getDefs (RightsecS _ s1 s2) = getDefs s1 ++ getDefs s2 | ||
| 79 | getDefs (ApplyS _ s1 s2) = getDefs s1 ++ getDefs s2 | ||
| 80 | getDefs (ProdS _ s1 s2) = getDefs s1 ++ getDefs s2 | ||
| 81 | getDefs (EitherS _ s1 s2) = getDefs s1 ++ getDefs s2 | ||
| 82 | getDefs (MaybeS _ s) = getDefs s | ||
| 83 | getDefs (ListS _ s) = getDefs s | ||
| 84 | getDefs (SetS _ s) = getDefs s | ||
| 85 | getDefs (MapS _ s) = getDefs s | ||
| 86 | 5 | paulosilva | getDefs (ReynoldsS _ s1 s2) = getDefs s1 ++ getDefs s2 |
| 87 | 1 | paulosilva | getDefs (FCompS _ s1 s2) = getDefs s1 ++ getDefs s2 |
| 88 | getDefs (OCompS _ s1 s2) = getDefs s1 ++ getDefs s2 | ||
| 89 | getDefs (OConvS _ s) = getDefs s | ||
| 90 | getDefs (OProdS _ s) = getDefs s | ||
| 91 | getDefs (OJoinS _ s) = getDefs s | ||
| 92 | getDefs (OMeetS _ s) = getDefs s | ||
| 93 | getDefs (OMaxS _ s) = getDefs s | ||
| 94 | getDefs (OMinS _ s) = getDefs s | ||
| 95 | getDefs (GCompS _ s1 s2) = getDefs s1 ++ getDefs s2 | ||
| 96 | getDefs (GConvS _ s) = getDefs s | ||
| 97 | getDefs (GLAdjS _ s) = getDefs s | ||
| 98 | getDefs (GUAdjS _ s) = getDefs s | ||
| 99 | getDefs (GLOrdS _ s) = getDefs s | ||
| 100 | getDefs (GUOrdS _ s) = getDefs s | ||
| 101 | getDefs _ = [] | ||
| 102 | |||
| 103 | ------------------------------------------------------------------------------- | ||
| 104 | |||
| 105 | replaceDefs :: (MonadError GalcError m, MonadReader Env' m) | ||
| 106 | => S -> m S | ||
| 107 | replaceDefs (RefS p n) = do -- TODO position in the substitution | ||
| 108 | extEnv <- asks external | ||
| 109 | maybe (maybe (throwError $ ReferenceError n) (return . RefExtS p) . | ||
| 110 | lookupEnv n $ extEnv) | ||
| 111 | return . lookupEnv n =<< asks internal | ||
| 112 | replaceDefs (NegS p s) = do | ||
| 113 | s' <- replaceDefs s | ||
| 114 | return $ NegS p s' | ||
| 115 | replaceDefs (MeetS p s1 s2) = do | ||
| 116 | s1' <- replaceDefs s1 | ||
| 117 | s2' <- replaceDefs s2 | ||
| 118 | return $ MeetS p s1' s2' | ||
| 119 | replaceDefs (JoinS p s1 s2) = do | ||
| 120 | s1' <- replaceDefs s1 | ||
| 121 | s2' <- replaceDefs s2 | ||
| 122 | return $ JoinS p s1' s2' | ||
| 123 | replaceDefs (ConvS p s) = do | ||
| 124 | s' <- replaceDefs s | ||
| 125 | return $ ConvS p s' | ||
| 126 | replaceDefs (CompS p s1 s2) = do | ||
| 127 | s1' <- replaceDefs s1 | ||
| 128 | s2' <- replaceDefs s2 | ||
| 129 | return $ CompS p s1' s2' | ||
| 130 | replaceDefs (SplitS p s1 s2) = do | ||
| 131 | s1' <- replaceDefs s1 | ||
| 132 | s2' <- replaceDefs s2 | ||
| 133 | return $ SplitS p s1' s2' | ||
| 134 | replaceDefs (OrdS p s) = do | ||
| 135 | s' <- replaceDefs s | ||
| 136 | return $ OrdS p s' | ||
| 137 | replaceDefs (FunS p s) = do | ||
| 138 | s' <- replaceDefs s | ||
| 139 | return $ FunS p s' | ||
| 140 | replaceDefs (LeftsecS p s1 s2) = do | ||
| 141 | s1' <- replaceDefs s1 | ||
| 142 | s2' <- replaceDefs s2 | ||
| 143 | return $ LeftsecS p s1' s2' | ||
| 144 | replaceDefs (RightsecS p s1 s2) = do | ||
| 145 | s1' <- replaceDefs s1 | ||
| 146 | s2' <- replaceDefs s2 | ||
| 147 | return $ RightsecS p s1' s2' | ||
| 148 | replaceDefs (ApplyS p s1 s2) = do | ||
| 149 | s1' <- replaceDefs s1 | ||
| 150 | s2' <- replaceDefs s2 | ||
| 151 | return $ ApplyS p s1' s2' | ||
| 152 | replaceDefs (ProdS p s1 s2) = do | ||
| 153 | s1' <- replaceDefs s1 | ||
| 154 | s2' <- replaceDefs s2 | ||
| 155 | return $ ProdS p s1' s2' | ||
| 156 | replaceDefs (EitherS p s1 s2) = do | ||
| 157 | s1' <- replaceDefs s1 | ||
| 158 | s2' <- replaceDefs s2 | ||
| 159 | return $ EitherS p s1' s2' | ||
| 160 | replaceDefs (MaybeS p s) = do | ||
| 161 | s' <- replaceDefs s | ||
| 162 | return $ MaybeS p s' | ||
| 163 | replaceDefs (ListS p s) = do | ||
| 164 | s' <- replaceDefs s | ||
| 165 | return $ ListS p s' | ||
| 166 | replaceDefs (SetS p s) = do | ||
| 167 | s' <- replaceDefs s | ||
| 168 | return $ SetS p s' | ||
| 169 | replaceDefs (MapS p s) = do | ||
| 170 | s' <- replaceDefs s | ||
| 171 | return $ MapS p s' | ||
| 172 | 5 | paulosilva | replaceDefs (ReynoldsS p s1 s2) = do |
| 173 | s1' <- replaceDefs s1 | ||
| 174 | s2' <- replaceDefs s2 | ||
| 175 | return $ ReynoldsS p s1' s2' | ||
| 176 | 1 | paulosilva | replaceDefs (FCompS p s1 s2) = do |
| 177 | s1' <- replaceDefs s1 | ||
| 178 | s2' <- replaceDefs s2 | ||
| 179 | return $ FCompS p s1' s2' | ||
| 180 | replaceDefs (OCompS p s1 s2) = do | ||
| 181 | s1' <- replaceDefs s1 | ||
| 182 | s2' <- replaceDefs s2 | ||
| 183 | return $ OCompS p s1' s2' | ||
| 184 | replaceDefs (OConvS p s) = do | ||
| 185 | s' <- replaceDefs s | ||
| 186 | return $ OConvS p s' | ||
| 187 | replaceDefs (OProdS p s) = do | ||
| 188 | s' <- replaceDefs s | ||
| 189 | return $ OProdS p s' | ||
| 190 | replaceDefs (OJoinS p s) = do | ||
| 191 | s' <- replaceDefs s | ||
| 192 | return $ OJoinS p s' | ||
| 193 | replaceDefs (OMeetS p s) = do | ||
| 194 | s' <- replaceDefs s | ||
| 195 | return $ (OMeetS p s') | ||
| 196 | replaceDefs (OMaxS p s) = do | ||
| 197 | s' <- replaceDefs s | ||
| 198 | return $ (OMaxS p s') | ||
| 199 | replaceDefs (OMinS p s) = do | ||
| 200 | s' <- replaceDefs s | ||
| 201 | return $ (OMinS p s') | ||
| 202 | replaceDefs (GDefS p n f1 f2 o1 o2) = do | ||
| 203 | f1' <- replaceDefs f1 | ||
| 204 | f2' <- replaceDefs f2 | ||
| 205 | o1' <- replaceDefs o1 | ||
| 206 | o2' <- replaceDefs o2 | ||
| 207 | return $ GDefS p n f1' f2' o1' o2' | ||
| 208 | replaceDefs (GCompS p s1 s2) = do | ||
| 209 | s1' <- replaceDefs s1 | ||
| 210 | s2' <- replaceDefs s2 | ||
| 211 | return $ GCompS p s1' s2' | ||
| 212 | replaceDefs (GConvS p s) = do | ||
| 213 | s' <- replaceDefs s | ||
| 214 | return $ GConvS p s' | ||
| 215 | replaceDefs (GLAdjS p s) = do | ||
| 216 | s' <- replaceDefs s | ||
| 217 | return $ GLAdjS p s' | ||
| 218 | replaceDefs (GUAdjS p s) = do | ||
| 219 | s' <- replaceDefs s | ||
| 220 | return $ GUAdjS p s' | ||
| 221 | replaceDefs (GLOrdS p s) = do | ||
| 222 | s' <- replaceDefs s | ||
| 223 | return $ GLOrdS p s' | ||
| 224 | replaceDefs (GUOrdS p s) = do | ||
| 225 | s' <- replaceDefs s | ||
| 226 | return $ GUOrdS p s' | ||
| 227 | replaceDefs s = return s | ||
| 228 | |||
| 229 | ------------------------------------------------------------------------------- |