never executed always true always false

    1 module Conjure.UI.TranslateSolution ( translateSolution ) where
    2 
    3 -- conjure
    4 import Conjure.Prelude
    5 import Conjure.Bug
    6 import Conjure.Language.Definition
    7 import Conjure.Language.Type ( TypeCheckerMode(..) )
    8 import Conjure.Language.Constant ( normaliseConstant )
    9 import Conjure.Language.Pretty
   10 import Conjure.Language.Instantiate
   11 import Conjure.Process.Enums ( removeEnumsFromParam, addEnumsAndUnnamedsBack )
   12 import Conjure.Process.Enumerate ( EnumerateDomain )
   13 import Conjure.UI.TranslateParameter ( translateParameter )
   14 import Conjure.Representations ( up )
   15 
   16 -- text
   17 import qualified Data.Text as T ( pack, stripPrefix )
   18 
   19 -- unordered-containers
   20 import qualified Data.HashMap.Strict as M
   21 
   22 
   23 translateSolution ::
   24     MonadFailDoc m =>
   25     MonadLog m =>
   26     NameGen m =>
   27     EnumerateDomain m =>
   28     MonadIO m =>
   29     (?typeCheckerMode :: TypeCheckerMode) =>
   30     Model ->      -- eprime model
   31     Model ->      -- essence param
   32     Model ->      -- eprime solution
   33     m Model       -- essence solution
   34 
   35 translateSolution (undoUnderscores -> eprimeModel) (undoUnderscores -> essenceParam') (undoUnderscores -> eprimeSolution) = do
   36 
   37     eprimeParam <- translateParameter False eprimeModel essenceParam'
   38     (_, essenceParam) <- removeEnumsFromParam eprimeModel essenceParam'
   39 
   40     let eprimeLettingsForEnums =
   41             [ (nm, fromInt (genericLength vals))
   42             | nm1                                          <- eprimeModel |> mInfo |> miEnumGivens
   43             , Declaration (LettingDomainDefnEnum nm2 vals) <- essenceParam' |> mStatements
   44             , nm1 == nm2
   45             , let nm = nm1 `mappend` "_EnumSize"
   46             ]
   47 
   48     let eprimeLettings0 = extractLettings essenceParam ++
   49                           extractLettings eprimeParam ++
   50                           extractLettings eprimeSolution ++
   51                           extractLettings eprimeModel ++
   52                           (eprimeModel |> mInfo |> miLettings) ++
   53                           eprimeLettingsForEnums
   54     let essenceFindNames = eprimeModel |> mInfo |> miFinds
   55     let essenceFinds     = eprimeModel |> mInfo |> miRepresentations
   56                                        |> filter (\ (n,_) -> n `elem` essenceFindNames )
   57 
   58     -- the right hand sides of these lettings may be expressions (as opposed to constants)
   59     -- that will make evaluation unnecessarily slower
   60     let eprimeLettings =
   61             [ (name, maybe val Constant (e2c val))
   62             | (name, val) <- eprimeLettings0
   63             ]
   64 
   65     eprimeLettings' <- forM eprimeLettings $ \ (name, val) -> do
   66         constant <- instantiateExpression eprimeLettings val
   67         return (name, constant)
   68 
   69     essenceFinds' <- forM essenceFinds $ \ (name, dom) -> do
   70         constant <- instantiateDomain eprimeLettings dom
   71         return (name, constant)
   72 
   73     essenceLettings <- forM essenceFinds' $ \ (name, domain) -> do
   74         (_, constant) <- up eprimeLettings' (name, domain)
   75         let origDomain = eprimeModel
   76                 |> mInfo |> miOriginalDomains
   77                 |> lookup name
   78                 |> fromMaybe (bug ("Missing original domain for:" <+> pretty name))
   79         return (name, origDomain, constant)
   80 
   81     let
   82         intToEnumConstant :: M.HashMap (Integer, Name) Constant
   83         intToEnumConstant = M.fromList $ concat
   84             [ [ ((i,ename), ConstantEnum ename vals v)
   85               | (i,v) <- zip allNats vals
   86               ]
   87             | Declaration (LettingDomainDefnEnum ename vals)
   88                     <- mStatements essenceParam'
   89                     ++ eprimeModel |> mInfo |> miEnumLettings |> map Declaration
   90             ]
   91 
   92     let
   93         unnameds :: [(Name, Expression)]
   94         unnameds = eprimeModel |> mInfo |> miUnnameds
   95 
   96     unnamedsAsEnumDomains <- forM unnameds $ \ (n, s') -> do
   97         s <- instantiateExpression eprimeLettings s'
   98         case s of
   99             ConstantInt _ size -> return $
  100                 let nms = [ mconcat [n, "_", Name (T.pack (show i))]
  101                           | i <- [1 .. size]
  102                           ]
  103                 in  Declaration (LettingDomainDefnEnum n nms)
  104             _ -> failDoc $ vcat [ "Expecting an integer value for" <+> pretty n
  105                              , "But got:" <+> pretty s
  106                              ]
  107 
  108     let outStmts =
  109             unnamedsAsEnumDomains ++
  110             sortNub
  111                 [ Declaration (Letting n (Constant (normaliseConstant y)))
  112                 | (n, d, x) <- essenceLettings
  113                 , let y = addEnumsAndUnnamedsBack
  114                                 (map fst unnameds)
  115                                 intToEnumConstant
  116                                 d x
  117                 ]
  118 
  119     let undefs = [ u | u@ConstantUndefined{} <- universeBi outStmts ]
  120 
  121     if null undefs
  122         then return def { mStatements = outStmts }
  123         else bug $ vcat
  124             [ "Undefined values in the output:" <++> vcat (map pretty undefs)
  125             , ""
  126             , "Complete output would have been the following."
  127             , ""
  128             , pretty $ def { mStatements = outStmts }
  129             ]
  130 
  131 undoUnderscores :: Model -> Model
  132 undoUnderscores model =
  133     let
  134         -- SR doesn't support identifiers that start with _
  135         -- we replaced them with UNDERSCORE__ in prologue
  136         -- undo that here
  137         onName :: Name -> Name
  138         onName (Name t) =
  139             case T.stripPrefix "UNDERSCORE__" t of
  140                 Nothing -> Name t
  141                 Just t' -> Name (mappend "_" t')
  142         onName n = n
  143 
  144     in
  145         transformBi onName model
  146