git.iko.soy/Idris-dev
on 54e4e41 help sign in
Idris-dev/src/Idris/Directives.hs
75 lines 3.2 kB history raw
2module Idris.Directives(directiveAction) where
4import Idris.AbsSyntax
5import Idris.ASTUtils
6import Idris.Imports
7import Idris.Output (sendHighlighting)
9import Idris.Core.Evaluate
10import Idris.Core.TT
12import Util.DynamicLinker
14-- | Run the action corresponding to a directive
15directiveAction :: Directive -> Idris ()
16directiveAction (DLib cgn lib) = do addLib cgn lib
17 addIBC (IBCLib cgn lib)
19directiveAction (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
24directiveAction (DFlag cgn flag) = do addIBC (IBCCGFlag cgn flag)
25 addFlag cgn flag
27directiveAction (DInclude cgn hdr) = do addHdr cgn hdr
28 addIBC (IBCHeader cgn hdr)
30directiveAction (DHide n) = do setAccessibility n Hidden
31 addIBC (IBCAccess n Hidden)
33directiveAction (DFreeze n) = do setAccessibility n Frozen
34 addIBC (IBCAccess n Frozen)
36directiveAction (DAccess acc) = do updateIState (\i -> i { default_access = acc })
38directiveAction (DDefault tot) = do updateIState (\i -> i { default_total = tot })
40directiveAction (DLogging lvl) = setLogLevel (fromInteger lvl)
42directiveAction (DDynamicLibs libs) = do added <- addDyLib libs
43 case added of
44 Left lib -> addIBC (IBCDyLib (lib_name lib))
45 Right msg -> fail $ msg
47directiveAction (DNameHint ty tyFC ns) = do ty' <- disambiguate ty
48 mapM_ (addNameHint ty' . fst) ns
49 mapM_ (\n -> addIBC (IBCNameHint (ty', fst n))) ns
50 sendHighlighting $
51 [(tyFC, AnnName ty' Nothing Nothing Nothing)] ++
52 map (\(n, fc) -> (fc, AnnBoundName n False)) ns
54directiveAction (DErrorHandlers fn nfc arg afc ns) =
55 do fn' <- disambiguate fn
56 ns' <- mapM (\(n, fc) -> do n' <- disambiguate n
57 return (n', fc)) ns
58 addFunctionErrorHandlers fn' arg (map fst ns')
59 mapM_ (addIBC .
60 IBCFunctionErrorHandler fn' arg . fst) ns'
61 sendHighlighting $
62 [(nfc, AnnName fn' Nothing Nothing Nothing),
63 (afc, AnnBoundName arg False)] ++
64 map (\(n, fc) -> (fc, AnnName n Nothing Nothing Nothing)) ns'
66directiveAction (DLanguage ext) = addLangExt ext
68directiveAction (DUsed fc fn arg) = addUsedName fc fn arg
70disambiguate :: Name -> Idris Name
71disambiguate n = do i <- getIState
72 case lookupCtxtName n (idris_implicits i) of
73 [(n', _)] -> return n'
74 [] -> throwError (NoSuchVariable n)
75 more -> throwError (CantResolveAlts (map fst more))