git.iko.soy/Idris-dev
on fd6898e help sign in
Idris-dev/src/Idris/Directives.hs
91 lines 4.0 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
25 let flags = words flag
26 mapM_ (\f -> addIBC (IBCCGFlag cgn f)) flags
27 mapM_ (addFlag cgn) flags
29directiveAction (DInclude cgn hdr) = do addHdr cgn hdr
30 addIBC (IBCHeader cgn hdr)
32directiveAction (DHide n') = do i <- getIState
33 ns <- allNamespaces n'
34 mapM_ (\n -> do setAccessibility n Hidden
35 addIBC (IBCAccess n Hidden)) ns
37directiveAction (DFreeze n) = do setAccessibility n Frozen
38 addIBC (IBCAccess n Frozen)
40directiveAction (DAccess acc) = do updateIState (\i -> i { default_access = acc })
42directiveAction (DDefault tot) = do updateIState (\i -> i { default_total = tot })
44directiveAction (DLogging lvl) = setLogLevel (fromInteger lvl)
46directiveAction (DDynamicLibs libs) = do added <- addDyLib libs
47 case added of
48 Left lib -> addIBC (IBCDyLib (lib_name lib))
49 Right msg -> fail $ msg
51directiveAction (DNameHint ty tyFC ns) = do ty' <- disambiguate ty
52 mapM_ (addNameHint ty' . fst) ns
53 mapM_ (\n -> addIBC (IBCNameHint (ty', fst n))) ns
54 sendHighlighting $
55 [(tyFC, AnnName ty' Nothing Nothing Nothing)] ++
56 map (\(n, fc) -> (fc, AnnBoundName n False)) ns
58directiveAction (DErrorHandlers fn nfc arg afc ns) =
59 do fn' <- disambiguate fn
60 ns' <- mapM (\(n, fc) -> do n' <- disambiguate n
61 return (n', fc)) ns
62 addFunctionErrorHandlers fn' arg (map fst ns')
63 mapM_ (addIBC .
64 IBCFunctionErrorHandler fn' arg . fst) ns'
65 sendHighlighting $
66 [(nfc, AnnName fn' Nothing Nothing Nothing),
67 (afc, AnnBoundName arg False)] ++
68 map (\(n, fc) -> (fc, AnnName n Nothing Nothing Nothing)) ns'
70directiveAction (DLanguage ext) = addLangExt ext
71directiveAction (DDeprecate n reason)
72 = do n' <- disambiguate n
73 addDeprecated n' reason
74 addIBC (IBCDeprecate n' reason)
75directiveAction (DAutoImplicits b)
76 = setAutoImpls b
77directiveAction (DUsed fc fn arg) = addUsedName fc fn arg
79disambiguate :: Name -> Idris Name
80disambiguate n = do i <- getIState
81 case lookupCtxtName n (idris_implicits i) of
82 [(n', _)] -> return n'
83 [] -> throwError (NoSuchVariable n)
84 more -> throwError (CantResolveAlts (map fst more))
86allNamespaces :: Name -> Idris [Name]
87allNamespaces n = do i <- getIState
88 case lookupCtxtName n (idris_implicits i) of
89 [(n', _)] -> return [n']
90 [] -> throwError (NoSuchVariable n)
91 more -> return (map fst more)