never executed always true always false

    1 module Conjure.Language.ModelStats
    2     ( givens, nbGivens, nbAbstractGivens
    3     , finds, nbFinds, nbAbstractFinds
    4     , declarations, nbDeclarations, nbAbstractDeclarations
    5     , lettings
    6     , domainNeedsRepresentation
    7     , modelInfo
    8     , modelDeclarationsJSON
    9     ) where
   10 
   11 import Conjure.Prelude
   12 import Conjure.Bug
   13 import Conjure.Language.Definition
   14 import Conjure.Language.Domain
   15 import Conjure.Language.Pretty
   16 
   17 -- containers
   18 import qualified Data.Map.Strict as M
   19 
   20 
   21 givens :: Model -> [(Name, Domain () Expression)]
   22 givens m = [ (nm,d) | Declaration (FindOrGiven Given nm d) <- mStatements m ]
   23 
   24 nbGivens :: Model -> Int
   25 nbGivens = length . givens
   26 
   27 nbAbstractGivens :: Model -> Int
   28 nbAbstractGivens = length . filter domainNeedsRepresentation . map snd . givens
   29 
   30 
   31 finds :: Model -> [(Name, Domain () Expression)]
   32 finds m = [ (nm,d) | Declaration (FindOrGiven Find nm d) <- mStatements m ]
   33 
   34 nbFinds :: Model -> Int
   35 nbFinds = length . finds
   36 
   37 nbAbstractFinds :: Model -> Int
   38 nbAbstractFinds = length . filter domainNeedsRepresentation . map snd . finds
   39 
   40 
   41 declarations :: Model -> [(Name, Domain () Expression)]
   42 declarations m = [ (nm,d) | Declaration (FindOrGiven _ nm d) <- mStatements m ]
   43 
   44 nbDeclarations :: Model -> Int
   45 nbDeclarations = length . declarations
   46 
   47 nbAbstractDeclarations :: Model -> Int
   48 nbAbstractDeclarations = length . filter domainNeedsRepresentation . map snd . declarations
   49 
   50 
   51 lettings :: Model -> [(Name, Expression)]
   52 lettings m = [ (nm,x) | Declaration (Letting nm x) <- mStatements m ]
   53 
   54 
   55 domainNeedsRepresentation :: (Pretty r, Pretty x) => Domain r x -> Bool
   56 domainNeedsRepresentation DomainBool{} = False
   57 domainNeedsRepresentation DomainInt{} = False
   58 domainNeedsRepresentation DomainEnum{} = False
   59 domainNeedsRepresentation DomainUnnamed{} = False
   60 domainNeedsRepresentation DomainTuple{} = False
   61 domainNeedsRepresentation DomainRecord{} = False
   62 domainNeedsRepresentation DomainVariant{} = False
   63 domainNeedsRepresentation (DomainMatrix _ inner) = domainNeedsRepresentation inner
   64 domainNeedsRepresentation DomainSet{}       = True
   65 domainNeedsRepresentation DomainMSet{}      = True
   66 domainNeedsRepresentation DomainFunction{}  = True
   67 domainNeedsRepresentation DomainSequence{}  = True
   68 domainNeedsRepresentation DomainRelation{}  = True
   69 domainNeedsRepresentation DomainPartition{} = True
   70 domainNeedsRepresentation (DomainReference _ (Just _)) = True
   71 domainNeedsRepresentation d = bug $ "domainNeedsRepresentation:" <+> pretty (show d)
   72 
   73 
   74 modelInfo :: Model -> Doc
   75 modelInfo m = vcat
   76     [ "Contains" <+> pretty   (nbGivens m) <+> "parameters        "
   77                  <+> prParens (pretty (nbAbstractGivens m) <+> "abstract")
   78     , "        " <+> pretty   (nbFinds  m) <+> "decision variables"
   79                  <+> prParens (pretty (nbAbstractFinds m ) <+> "abstract")
   80     ]
   81 
   82 
   83 modelDeclarationsJSON :: Model -> JSONValue
   84 modelDeclarationsJSON m = toJSON
   85     [ M.fromList $ case d of
   86         FindOrGiven forg name dom ->
   87             [ "kind"   ~~ show forg
   88             , "name"   ~~ r name
   89             , "domain" ~~ r dom
   90             ]
   91         Letting name x ->
   92             [ "kind"   ~~ "letting"
   93             , "name"   ~~ r name
   94             , "value"  ~~ r x
   95             ]
   96         GivenDomainDefnEnum name ->
   97             [ "kind"   ~~ "enumerated type"
   98             , "name"   ~~ r name
   99             ]
  100         LettingDomainDefnEnum name vals ->
  101             [ "kind"   ~~ "enumerated type"
  102             , "name"   ~~ r name
  103             , "values" ~~ r (prettyList id "," vals)
  104             ]
  105         LettingDomainDefnUnnamed name size ->
  106             [ "kind"   ~~ "unnamed type"
  107             , "name"   ~~ r name
  108             , "size"   ~~ r size
  109             ]
  110     | Declaration d <- mStatements m
  111     ]
  112     where
  113         (~~) :: String -> String -> (String, String)
  114         x ~~ y = (x, y)
  115         r s = render 100000 (pretty s)