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 DomainPermutation{} = True
   71 domainNeedsRepresentation (DomainReference _ (Just _)) = True
   72 domainNeedsRepresentation d = bug $ "domainNeedsRepresentation:" <+> pretty (show d)
   73 
   74 
   75 modelInfo :: Model -> Doc
   76 modelInfo m = vcat
   77     [ "Contains" <+> pretty   (nbGivens m) <+> "parameters        "
   78                  <+> prParens (pretty (nbAbstractGivens m) <+> "abstract")
   79     , "        " <+> pretty   (nbFinds  m) <+> "decision variables"
   80                  <+> prParens (pretty (nbAbstractFinds m ) <+> "abstract")
   81     ]
   82 
   83 
   84 modelDeclarationsJSON :: Model -> JSONValue
   85 modelDeclarationsJSON m = toJSON
   86     [ M.fromList $ case d of
   87         FindOrGiven forg name dom ->
   88             [ "kind"   ~~ show forg
   89             , "name"   ~~ r name
   90             , "domain" ~~ r dom
   91             ]
   92         Letting name x ->
   93             [ "kind"   ~~ "letting"
   94             , "name"   ~~ r name
   95             , "value"  ~~ r x
   96             ]
   97         GivenDomainDefnEnum name ->
   98             [ "kind"   ~~ "enumerated type"
   99             , "name"   ~~ r name
  100             ]
  101         LettingDomainDefnEnum name vals ->
  102             [ "kind"   ~~ "enumerated type"
  103             , "name"   ~~ r name
  104             , "values" ~~ r (prettyList id "," vals)
  105             ]
  106         LettingDomainDefnUnnamed name size ->
  107             [ "kind"   ~~ "unnamed type"
  108             , "name"   ~~ r name
  109             , "size"   ~~ r size
  110             ]
  111     | Declaration d <- mStatements m
  112     ]
  113     where
  114         (~~) :: String -> String -> (String, String)
  115         x ~~ y = (x, y)
  116         r s = render 100000 (pretty s)