@@ -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,54 @@ 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 $
63+ [(tyFC, AnnName ty' Nothing Nothing Nothing)] ++ map (\(n, fc) -> (fc, AnnBoundName n False)) ns
64+
65+directiveAction (DErrorHandlers fn nfc arg afc ns) = do
66+ fn' <- disambiguate fn
67+ ns' <- mapM (\(n, fc) -> do
68+ n' <- disambiguate n
69+ return (n', fc)) ns
70+ addFunctionErrorHandlers fn' arg (map fst ns')
71+ mapM_ (addIBC . IBCFunctionErrorHandler fn' arg . fst) ns'
72+ sendHighlighting $
73+ [ (nfc, AnnName fn' Nothing Nothing Nothing)
74+ , (afc, AnnBoundName arg False)
75+ ] ++ map (\(n, fc) -> (fc, AnnName n Nothing Nothing Nothing)) ns'
6876
6977directiveAction (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
78+
79+directiveAction (DDeprecate n reason) = do
80+ n' <- disambiguate n
81+ addDeprecated n' reason
82+ addIBC (IBCDeprecate n' reason)
83+
84+directiveAction (DAutoImplicits b) = setAutoImpls b
85+directiveAction (DUsed fc fn arg) = addUsedName fc fn arg
7786
7887disambiguate :: 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))
88+disambiguate n = do
89+ i <- getIState
90+ case lookupCtxtName n (idris_implicits i) of
91+ [(n', _)] -> return n'
92+ [] -> throwError (NoSuchVariable n)
93+ more -> throwError (CantResolveAlts (map fst more))
94+
8495
8596allNamespaces :: 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)
97+allNamespaces n = do
98+ i <- getIState
99+ case lookupCtxtName n (idris_implicits i) of
100+ [(n', _)] -> return [n']
101+ [] -> throwError (NoSuchVariable n)
102+ more -> return (map fst more)