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 ] }