never executed always true always false
    1 module Conjure.Process.LettingsForComplexInDoms
    2     ( lettingsForComplexInDoms
    3     , inlineLettingDomainsForDecls
    4     , removeDomainLettings
    5     ) where
    6 
    7 import Conjure.Prelude
    8 import Conjure.Language.Definition
    9 import Conjure.Language.Domain
   10 import Conjure.Language.Pretty
   11 
   12 
   13 -- | if the domain of a declaration contains a reference to another declaration (a given)
   14 --   that needs a representation, hell breaks loose.
   15 --   specifically, name-resolution needs to be rerun after representation selection.
   16 --   however, this transformation (as part of `Conjure.UI.Model.prologue`) cleans this up by introducing
   17 --   extra letting statements.
   18 lettingsForComplexInDoms ::
   19     MonadFailDoc m =>
   20     NameGen m =>
   21     Model -> m Model
   22 lettingsForComplexInDoms m = do
   23     let
   24         expressionExtract expr@Constant{}        = return expr
   25         expressionExtract expr@AbstractLiteral{} = return expr
   26         expressionExtract expr@Reference{}       = return expr
   27         expressionExtract expr = do
   28             newLetting <- nextName "let"
   29             tell [Declaration (Letting newLetting expr)]        -- new declarations
   30             return (Reference newLetting Nothing)               -- the replacement expression
   31 
   32     statements <- forM (mStatements m) $ \ st ->
   33         case st of
   34             Declaration (FindOrGiven forg name domain) -> do
   35                 (domain', newLettings) <- runWriterT (mapM expressionExtract domain)
   36                 return (newLettings ++ [Declaration (FindOrGiven forg name domain')])
   37             Declaration (LettingDomainDefnUnnamed name expr) -> do
   38                 (expr', newLettings) <- runWriterT (expressionExtract expr)
   39                 return (newLettings ++ [Declaration (LettingDomainDefnUnnamed name expr')])
   40             _ -> return [st]
   41     return m { mStatements = concat statements }
   42 
   43 
   44 -- | inline letting domains for declarations, before saving the original domain in the logs
   45 inlineLettingDomainsForDecls :: MonadFailDoc m => Model -> m Model
   46 inlineLettingDomainsForDecls m = do
   47     let
   48         f (DomainReference name Nothing) = do
   49             (ctxt, unnameds) <- gets id
   50             case name `lookup` ctxt of
   51                 Just d -> transformM f d
   52                 _ -> if name `elem` unnameds
   53                         then return (DomainReference name Nothing)
   54                         else failDoc $ vcat
   55                                 $ ("No value for:" <+> pretty name)
   56                                 : "Bindings in context:"
   57                                 : prettyContext ctxt
   58         f d = return d
   59 
   60     flip evalStateT ( []    -- name, domain pairs for letting domains.
   61                     , []    -- names for unnamed types. so they can be skipped.
   62                     ) $ do
   63         statements <- forM (mStatements m) $ \ st ->
   64             case st of
   65                 Declaration (Letting name (Domain domain)) -> do
   66                     modify (([(name, domain)], []) `mappend`)
   67                     return st
   68                 Declaration (LettingDomainDefnUnnamed name _) -> do
   69                     modify (([], [name]) `mappend`)
   70                     return st
   71                 Declaration (FindOrGiven forg name domain) -> do
   72                     domain' <- transformM f domain
   73                     return (Declaration (FindOrGiven forg name domain'))
   74                 _ -> return st
   75         return m { mStatements = statements }
   76 
   77 
   78 -- | remove domain lettings, only after name resolution
   79 removeDomainLettings :: Monad m => Model -> m Model
   80 removeDomainLettings m =
   81     return m { mStatements = concat [ case st of
   82                                         Declaration (Letting _ (Domain _)) -> []
   83                                         _ -> [st]
   84                                     | st <- mStatements m
   85                                     ] }