@@ -13,28 +13,35 @@ import Util.DynamicLinker
1313
1414-- | Run the action corresponding to a directive
1515directiveAction :: Directive -> Idris ()
16−directiveAction (DLib cgn lib) = do addLib cgn lib
17− addIBC (IBCLib cgn lib)
16+directiveAction (DLib cgn lib) = do
17+ addLib cgn lib
18+ addIBC (IBCLib cgn lib)
1819
19−directiveAction (DLink cgn obj) = do dirs <- allImportDirs
20− o <- runIO $ findInPath dirs obj
21− addIBC (IBCObj cgn obj) -- just name, search on loading ibc
22− addObjectFile cgn o
20+directiveAction (DLink cgn obj) = do
21+ dirs <- allImportDirs
22+ o <- runIO $ findInPath dirs obj
23+ addIBC (IBCObj cgn obj) -- just name, search on loading ibc
24+ addObjectFile cgn o
2325
2426directiveAction (DFlag cgn flag) = do
25− let flags = words flag
26− mapM_ (\f -> addIBC (IBCCGFlag cgn f)) flags
27− mapM_ (addFlag cgn) flags
28−
29−directiveAction (DInclude cgn hdr) = do addHdr cgn hdr
30− addIBC (IBCHeader cgn hdr)
31−
32−directiveAction (DHide n') = do ns <- allNamespaces n'
33− mapM_ (\n -> do setAccessibility n Hidden
34− addIBC (IBCAccess n Hidden)) ns
35−directiveAction (DFreeze n') = do ns <- allNamespaces n'
36− mapM_ (\n -> do setAccessibility n Frozen
37− addIBC (IBCAccess n Frozen)) ns
27+ let flags = words flag
28+ mapM_ (\f -> addIBC (IBCCGFlag cgn f)) flags
29+ mapM_ (addFlag cgn) flags
30+
31+directiveAction (DInclude cgn hdr) = do
32+ addHdr cgn hdr
33+ addIBC (IBCHeader cgn hdr)
34+
35+directiveAction (DHide n') = do
36+ ns <- allNamespaces n'
37+ mapM_ (\n -> do
38+ setAccessibility n Hidden
39+ addIBC (IBCAccess n Hidden)) ns
40+directiveAction (DFreeze n') = do
41+ ns <- allNamespaces n'
42+ mapM_ (\n -> do
43+ setAccessibility n Frozen
44+ addIBC (IBCAccess n Frozen)) ns
3845
3946directiveAction (DAccess acc) = do updateIState (\i -> i { default_access = acc })
4047
@@ -42,49 +49,58 @@ directiveAction (DDefault tot) = do updateIState (\i -> i { default_total = tot
4249
4350directiveAction (DLogging lvl) = setLogLevel (fromInteger lvl)
4451
45−directiveAction (DDynamicLibs libs) = do added <- addDyLib libs
46− case added of
47− Left lib -> addIBC (IBCDyLib (lib_name lib))
48− Right msg -> fail $ msg
49−
50−directiveAction (DNameHint ty tyFC ns) = do ty' <- disambiguate ty
51− mapM_ (addNameHint ty' . fst) ns
52− mapM_ (\n -> addIBC (IBCNameHint (ty', fst n))) ns
53− sendHighlighting $
54− [(tyFC, AnnName ty' Nothing Nothing Nothing)] ++
55− map (\(n, fc) -> (fc, AnnBoundName n False)) ns
56−
57−directiveAction (DErrorHandlers fn nfc arg afc ns) =
58− do fn' <- disambiguate fn
59− ns' <- mapM (\(n, fc) -> do n' <- disambiguate n
60− return (n', fc)) ns
61− addFunctionErrorHandlers fn' arg (map fst ns')
62− mapM_ (addIBC .
63− IBCFunctionErrorHandler fn' arg . fst) ns'
64− sendHighlighting $
65− [(nfc, AnnName fn' Nothing Nothing Nothing),
66− (afc, AnnBoundName arg False)] ++
67− map (\(n, fc) -> (fc, AnnName n Nothing Nothing Nothing)) ns'
52+directiveAction (DDynamicLibs libs) = do
53+ added <- addDyLib libs
54+ case added of
55+ Left lib -> addIBC (IBCDyLib (lib_name lib))
56+ Right msg -> fail $ msg
57+
58+directiveAction (DNameHint ty tyFC ns) = do
59+ ty' <- disambiguate ty
60+ mapM_ (addNameHint ty' . fst) ns
61+ mapM_ (\n -> addIBC (IBCNameHint (ty', fst n))) ns
62+ sendHighlighting $ [(tyFC, AnnName ty' Nothing Nothing Nothing)] ++ map (\(n, fc) -> (fc, AnnBoundName n False)) ns
63+
64+directiveAction (DErrorHandlers fn nfc arg afc ns) = do
65+ fn' <- disambiguate fn
66+ ns' <- mapM (\(n, fc) -> do
67+ n' <- disambiguate n
68+ return (n', fc)) ns
69+ addFunctionErrorHandlers fn' arg (map fst ns')
70+ mapM_ (addIBC . IBCFunctionErrorHandler fn' arg . fst) ns'
71+ sendHighlighting $
72+ [ (nfc, AnnName fn' Nothing Nothing Nothing)
73+ , (afc, AnnBoundName arg False)
74+ ] ++ map (\(n, fc) -> (fc, AnnName n Nothing Nothing Nothing)) ns'
6875
6976directiveAction (DLanguage ext) = addLangExt ext
70−directiveAction (DDeprecate n reason)
71− = do n' <- disambiguate n
72− addDeprecated n' reason
73− addIBC (IBCDeprecate n' reason)
74−directiveAction (DAutoImplicits b)
75− = setAutoImpls b
76−directiveAction (DUsed fc fn arg) = addUsedName fc fn arg
77+
78+directiveAction (DDeprecate n reason) = do
79+ n' <- disambiguate n
80+ addDeprecated n' reason
81+ addIBC (IBCDeprecate n' reason)
82+
83+directiveAction (DFragile n reason) = do
84+ n' <- disambiguate n
85+ addFragile n' reason
86+ addIBC (IBCFragile n' reason)
87+
88+directiveAction (DAutoImplicits b) = setAutoImpls b
89+directiveAction (DUsed fc fn arg) = addUsedName fc fn arg
7790
7891disambiguate :: Name -> Idris Name
79−disambiguate n = do i <- getIState
80− case lookupCtxtName n (idris_implicits i) of
81− [(n', _)] -> return n'
82− [] -> throwError (NoSuchVariable n)
83− more -> throwError (CantResolveAlts (map fst more))
92+disambiguate n = do
93+ i <- getIState
94+ case lookupCtxtName n (idris_implicits i) of
95+ [(n', _)] -> return n'
96+ [] -> throwError (NoSuchVariable n)
97+ more -> throwError (CantResolveAlts (map fst more))
98+
8499
85100allNamespaces :: Name -> Idris [Name]
86−allNamespaces n = do i <- getIState
87− case lookupCtxtName n (idris_implicits i) of
88− [(n', _)] -> return [n']
89− [] -> throwError (NoSuchVariable n)
90− more -> return (map fst more)
101+allNamespaces n = do
102+ i <- getIState
103+ case lookupCtxtName n (idris_implicits i) of
104+ [(n', _)] -> return [n']
105+ [] -> throwError (NoSuchVariable n)
106+ more -> return (map fst more)