never executed always true always false

    1 module Conjure.Language.CategoryOf
    2     ( Category(..)
    3     , categoryOf
    4     , categoryChecking
    5     , initInfo_Lettings
    6     ) where
    7 
    8 -- conjure
    9 import Conjure.Prelude
   10 import Conjure.UserError
   11 import Conjure.Language.Definition
   12 import Conjure.Language.Domain
   13 import Conjure.Language.Pretty
   14 
   15 
   16 data Category = CatBottom | CatConstant | CatParameter | CatQuantified | CatDecision
   17     deriving (Eq, Ord, Show)
   18 
   19 instance Pretty Category where
   20     pretty CatBottom = "_|_"
   21     pretty CatConstant = "constant"
   22     pretty CatParameter = "parameter"
   23     pretty CatQuantified = "quantified"
   24     pretty CatDecision = "decision"
   25 
   26 class CategoryOf a where
   27     categoryOf :: a -> Category
   28 
   29 instance CategoryOf Expression where
   30     categoryOf (Reference _ (Just ref)) = categoryOf ref
   31     -- TODO: the following should check for which variable we quantify over
   32     categoryOf x@Comprehension{} = maximum $ filter (CatQuantified/=) $ CatBottom : map categoryOf (children x)
   33     categoryOf x                 = maximum                            $ CatBottom : map categoryOf (children x)
   34 
   35 instance CategoryOf ReferenceTo where
   36     categoryOf (Alias                x) = categoryOf x
   37     categoryOf (InComprehension      _) = CatQuantified
   38     categoryOf (DeclNoRepr  forg _ _ _) = categoryOf forg
   39     categoryOf (DeclHasRepr forg _ _  ) = categoryOf forg
   40     categoryOf RecordField{}            = CatBottom
   41     categoryOf VariantField{}           = CatBottom
   42 
   43 instance CategoryOf Generator where
   44      categoryOf (GenDomainNoRepr  _ x) = categoryOf x
   45      categoryOf (GenDomainHasRepr _ x) = categoryOf x
   46      categoryOf (GenInExpr        _ x) = categoryOf x
   47 
   48 instance CategoryOf x => CategoryOf (Domain r x) where
   49     categoryOf dom = maximum (CatBottom : toList (fmap categoryOf dom))
   50 
   51 instance CategoryOf FindOrGiven where
   52     categoryOf Find = CatDecision
   53     categoryOf Given = CatParameter
   54     categoryOf Quantified = CatQuantified
   55     categoryOf CutFind = CatDecision
   56     categoryOf LocalFind = CatDecision
   57 
   58 
   59 -- | Category checking to check if domains have anything >CatParameter in them.
   60 --   Run only after name resolution.
   61 categoryChecking :: (MonadFailDoc m, MonadUserError m) => Model -> m Model
   62 categoryChecking m = do
   63     errors1 <- fmap concat $ forM (mStatements m) $ \ st -> case st of
   64         Declaration (FindOrGiven _forg name domain) -> do
   65             let category = categoryOf domain
   66             return [(domain, (name, category)) | category > CatParameter]
   67         _ -> return []
   68     errors2 <- fmap concat $ forM (universeBi (mStatements m) :: [Domain () Expression]) $ \ domain -> do
   69         let category = categoryOf domain
   70         return [ (domain, category)
   71                | category > CatQuantified
   72                , domain `notElem` map fst errors1        -- only if this is a new error
   73                ]
   74 
   75     if null errors1 && null errors2
   76         then return m
   77         else userErr1 $ vcat
   78             $  [ "Category checking failed." ]
   79             ++ concat ( [ [ "The domain   :" <+> pretty domain
   80                               , "Its category :" <+> pretty category
   81                               , "In the definition of:" <+> pretty name
   82                               , ""
   83                               ]
   84                             | (domain, (name, category)) <- nub errors1
   85                             ] )
   86             ++ concat ( [ [ "The domain   :" <+> pretty domain
   87                               , "Its category :" <+> pretty category
   88                               , ""
   89                               ]
   90                             | (domain, category) <- nub errors2
   91                             ] )
   92 
   93 initInfo_Lettings :: Model -> Model
   94 initInfo_Lettings model = model { mInfo = info }
   95     where
   96         info = (mInfo model)
   97             { miLettings = [ (nm,x) | Declaration (Letting nm x) <- mStatements model
   98                                     , categoryOf x <= CatParameter
   99                                     ]
  100             }