git.iko.soy/Idris-dev
on 449089d help sign in
Idris-dev/src/Idris/Directives.hs
82 lines 3.5 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 setAccessibility n Hidden
33 addIBC (IBCAccess n Hidden)
35directiveAction (DFreeze n) = do setAccessibility n Frozen
36 addIBC (IBCAccess n Frozen)
38directiveAction (DAccess acc) = do updateIState (\i -> i { default_access = acc })
40directiveAction (DDefault tot) = do updateIState (\i -> i { default_total = tot })
42directiveAction (DLogging lvl) = setLogLevel (fromInteger lvl)
44directiveAction (DDynamicLibs libs) = do added <- addDyLib libs
45 case added of
46 Left lib -> addIBC (IBCDyLib (lib_name lib))
47 Right msg -> fail $ msg
49directiveAction (DNameHint ty tyFC ns) = do ty' <- disambiguate ty
50 mapM_ (addNameHint ty' . fst) ns
51 mapM_ (\n -> addIBC (IBCNameHint (ty', fst n))) ns
52 sendHighlighting $
53 [(tyFC, AnnName ty' Nothing Nothing Nothing)] ++
54 map (\(n, fc) -> (fc, AnnBoundName n False)) ns
56directiveAction (DErrorHandlers fn nfc arg afc ns) =
57 do fn' <- disambiguate fn
58 ns' <- mapM (\(n, fc) -> do n' <- disambiguate n
59 return (n', fc)) ns
60 addFunctionErrorHandlers fn' arg (map fst ns')
61 mapM_ (addIBC .
62 IBCFunctionErrorHandler fn' arg . fst) ns'
63 sendHighlighting $
64 [(nfc, AnnName fn' Nothing Nothing Nothing),
65 (afc, AnnBoundName arg False)] ++
66 map (\(n, fc) -> (fc, AnnName n Nothing Nothing Nothing)) ns'
68directiveAction (DLanguage ext) = addLangExt ext
69directiveAction (DDeprecate n reason)
70 = do n' <- disambiguate n
71 addDeprecated n' reason
72 addIBC (IBCDeprecate n' reason)
73directiveAction (DAutoImplicits b)
74 = setAutoImpls b
75directiveAction (DUsed fc fn arg) = addUsedName fc fn arg
77disambiguate :: Name -> Idris Name
78disambiguate n = do i <- getIState
79 case lookupCtxtName n (idris_implicits i) of
80 [(n', _)] -> return n'
81 [] -> throwError (NoSuchVariable n)
82 more -> throwError (CantResolveAlts (map fst more))