idris 0.9.9.2 → 0.9.9.3
raw patch · 73 files changed
+5636/−3689 lines, 73 filesdep +ansi-wl-pprintdep ~directorydep ~parsersdep ~trifectasetup-changed
Dependencies added: ansi-wl-pprint
Dependency ranges changed: directory, parsers, trifecta
Files
- Makefile +3/−0
- Setup.hs +113/−133
- effects/Effects.idr +65/−3
- effects/Makefile +5/−4
- idris.cabal +189/−82
- javascript/Makefile +4/−3
- js/Runtime-browser.js +0/−3
- js/Runtime-common.js +0/−400
- js/Runtime-node.js +0/−6
- jsrts/Runtime-browser.js +3/−0
- jsrts/Runtime-common.js +51/−0
- jsrts/Runtime-node.js +6/−0
- jsrts/jsbn/LICENSE +40/−0
- jsrts/jsbn/jsbn.js +1235/−0
- lib/Data/Bits.idr +6/−6
- lib/Decidable/Equality.idr +18/−0
- lib/Language/Reflection/Errors.idr +42/−0
- lib/Makefile +5/−4
- lib/Prelude.idr +8/−4
- lib/Prelude/Bits.idr +56/−0
- lib/Prelude/Chars.idr +6/−0
- lib/base.ipkg +2/−2
- llvm/Makefile +1/−1
- llvm/defs.c +4/−0
- rts/Makefile +1/−1
- rts/idris_rts.c +12/−3
- src/Core/ProofState.hs +49/−23
- src/Core/TT.hs +3/−0
- src/Core/Unify.hs +22/−4
- src/IRTS/CodegenJavaScript.hs +342/−48
- src/IRTS/CodegenLLVM.hs +32/−19
- src/IRTS/Simplified.hs +7/−7
- src/Idris/AbsSyntax.hs +25/−11
- src/Idris/AbsSyntaxTree.hs +18/−8
- src/Idris/Colours.hs +8/−6
- src/Idris/Completion.hs +1/−1
- src/Idris/Coverage.hs +12/−21
- src/Idris/DSL.hs +3/−0
- src/Idris/Delaborate.hs +3/−3
- src/Idris/Docs.hs +1/−1
- src/Idris/ElabDecls.hs +14/−6
- src/Idris/ElabTerm.hs +25/−16
- src/Idris/IBC.hs +5/−3
- src/Idris/ParseData.hs +215/−0
- src/Idris/ParseExpr.hs +1042/−0
- src/Idris/ParseHelpers.hs +461/−0
- src/Idris/ParseOps.hs +137/−0
- src/Idris/Parser.hs +1053/−2771
- src/Idris/Prover.hs +3/−3
- src/Idris/REPL.hs +34/−12
- src/Idris/REPLParser.hs +7/−2
- src/Pkg/Package.hs +3/−4
- src/Util/System.hs +4/−1
- test/Makefile +36/−0
- test/reg007/expected +12/−0
- test/reg007/reg007.lidr +3/−3
- test/reg021/expected +0/−0
- test/reg021/reg021.idr +22/−0
- test/reg021/run +3/−0
- test/reg022/expected +0/−0
- test/reg022/reg022.idr +18/−0
- test/reg022/run +3/−0
- test/reg023/expected +12/−0
- test/reg023/reg023.idr +8/−0
- test/reg023/run +3/−0
- test/reg024/expected +1/−0
- test/reg024/reg024.idr +31/−0
- test/reg024/run +4/−0
- test/runtest.pl +63/−61
- test/test030/Reflect.idr +1/−0
- test/test031/expected +0/−0
- test/test031/run +4/−0
- test/test031/test031.idr +8/−0
Makefile view
@@ -19,6 +19,9 @@ test_java: $(MAKE) -C test IDRIS=../dist/build/idris test_java +test_llvm:+ $(MAKE) -C test IDRIS=../dist/build/idris test_llvm+ relib: $(MAKE) -C lib IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts clean $(MAKE) -C effects IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts DIST=../dist/build clean
Setup.hs view
@@ -20,158 +20,138 @@ -- After Idris is built, we need to check and install the prelude and other libs -make verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "make"+-- -----------------------------------------------------------------------------+-- Idris Command Path -#ifdef mingw32_HOST_OS -- make on mingw32 exepects unix style separators+#ifdef mingw32_HOST_OS (<//>) = (Px.</>)-idrisCmd local = Px.joinPath $ splitDirectories $- ".." <//> buildDir local <//> "idris" <//> "idris"-rtsDir local = Px.joinPath $ splitDirectories $- ".." <//> buildDir local <//> "rts" <//> "libidris_rts"+idrisCmd local = Px.joinPath $ splitDirectories $ ".." <//> buildDir local <//> "idris" <//> "idris" #else idrisCmd local = ".." </> buildDir local </> "idris" </> "idris"-rtsDir local = ".." </> buildDir local </> "rts" </> "libidris_rts" #endif -cleanStdLib verbosity- = do make verbosity [ "-C", "lib", "clean", "IDRIS=idris" ]- make verbosity [ "-C", "effects", "clean", "IDRIS=idris" ]- make verbosity [ "-C", "javascript", "clean", "IDRIS=idris" ]+-- -----------------------------------------------------------------------------+-- Make Commands -cleanJavaPom verbosity - = do execPomExists <- doesFileExist ("java" </> "executable_pom.xml")- when execPomExists $ removeFile ("java" </> "executable_pom.xml")+make verbosity =+ P.runProgramInvocation verbosity . P.simpleProgramInvocation "make" -cleanLLVMLib verbosity = make verbosity ["-C", "llvm", "clean"]+-- -----------------------------------------------------------------------------+-- Flags -installStdLib pkg local withoutEffects verbosity copy- = do let dirs = L.absoluteInstallDirs pkg local copy- let idir = datadir dirs- let icmd = idrisCmd local- putStrLn $ "Installing libraries in " ++ idir- make verbosity- [ "-C", "lib", "install"- , "TARGET=" ++ idir- , "IDRIS=" ++ icmd- ]- unless withoutEffects $- make verbosity- [ "-C", "effects", "install"- , "TARGET=" ++ idir- , "IDRIS=" ++ icmd- ]- make verbosity- [ "-C", "javascript", "install"- , "TARGET=" ++ idir- , "IDRIS=" ++ icmd- ]- let idirRts = idir </> "rts"- putStrLn $ "Installing run time system in " ++ idirRts- make verbosity- [ "-C", "rts", "install"- , "TARGET=" ++ idirRts- , "IDRIS=" ++ icmd- ]+usesLLVM :: S.ConfigFlags -> Bool+usesLLVM flags =+ case lookup (FlagName "llvm") (S.configConfigurationsFlags flags) of+ Just True -> True+ Just False -> False+ Nothing -> True -installLLVMLib verbosity pkg local copy =- let idir = datadir $ L.absoluteInstallDirs pkg local copy in- make verbosity ["-C", "llvm", "install", "TARGET=" ++ idir </> "llvm"]+usesEffects :: S.ConfigFlags -> Bool+usesEffects flags =+ case lookup (FlagName "effects") (S.configConfigurationsFlags flags) of+ Just True -> True+ Just False -> False+ Nothing -> True -buildLLVMLib verbosity = make verbosity ["-C", "llvm", "all"]+-- -----------------------------------------------------------------------------+-- Clean -installJavaPom pkg local verbosity copy version = do- putStrLn $ "Installing java pom template" - let dir = datadir $ L.absoluteInstallDirs pkg local copy- copyFile ("java" </> "executable_pom.xml") (dir </> "executable_pom.xml")+idrisClean _ flags _ _ = do+ cleanStdLib+ cleanLLVM+ where+ verbosity = S.fromFlag $ S.cleanVerbosity flags --- This is a hack. I don't know how to tell cabal that a data file needs--- installing but shouldn't be in the distribution. And it won't make the--- distribution if it's not there, so instead I just delete--- the file after configure.+ cleanStdLib = do+ makeClean "lib"+ makeClean "effects"+ makeClean "javascript" -removeLibIdris local verbosity- = do let icmd = idrisCmd local- make verbosity- [ "-C", "rts", "clean"- , "IDRIS=" ++ icmd- ]+ cleanLLVM = makeClean "llvm" -checkStdLib local withoutEffects verbosity- = do let icmd = idrisCmd local- putStrLn $ "Building libraries..."- make verbosity- [ "-C", "lib", "check"- , "IDRIS=" ++ icmd- ]- unless withoutEffects $- make verbosity- [ "-C", "effects", "check"- , "IDRIS=" ++ icmd- ]- make verbosity- [ "-C", "javascript", "check"- , "IDRIS=" ++ icmd- ]- make verbosity- [ "-C", "rts", "check"- , "IDRIS=" ++ icmd- ]+ makeClean dir = make verbosity [ "-C", dir, "clean", "IDRIS=idris" ] -llvmFlag flags = - case lookup (FlagName "llvm") (S.configConfigurationsFlags flags) of- Just True -> True- Just False -> False- Nothing -> True -noEffectsFlag flags =- case lookup (FlagName "noeffects") (S.configConfigurationsFlags flags) of- Just True -> True- Just False -> False- Nothing -> False+-- -----------------------------------------------------------------------------+-- Configure -preparePoms version- = do execPomTemplate <- TIO.readFile ("java" </> "executable_pom_template.xml")- TIO.writeFile ("java" </> "executable_pom.xml") (insertVersion execPomTemplate)- where- insertVersion template = - T.replace (T.pack "$RTS-VERSION$") (T.pack $ display version) template+idrisConfigure _ flags _ local = do+ configureRTS+ where+ verbosity = S.fromFlag $ S.configVerbosity flags+ version = pkgVersion . package $ localPkgDescr local + -- This is a hack. I don't know how to tell cabal that a data file needs+ -- installing but shouldn't be in the distribution. And it won't make the+ -- distribution if it's not there, so instead I just delete+ -- the file after configure.+ configureRTS = make verbosity ["-C", "rts", "clean"]++-- -----------------------------------------------------------------------------+-- Build++idrisBuild _ flags _ local = do+ buildStdLib+ buildRTS+ when (usesLLVM $ configFlags local) buildLLVM+ where+ verbosity = S.fromFlag $ S.buildVerbosity flags++ buildStdLib = do+ putStrLn "Building libraries..."+ makeBuild "lib"+ when (usesEffects $ configFlags local) $ makeBuild "effects"+ makeBuild "javascript"+ where+ makeBuild dir = make verbosity [ "-C", dir, "build" , "IDRIS=" ++ idrisCmd local]++ buildRTS = make verbosity ["-C", "rts", "build"]++ buildLLVM = make verbosity ["-C", "llvm", "build"]++-- -----------------------------------------------------------------------------+-- Copy/Install++idrisInstall verbosity copy pkg local = do+ installStdLib+ installRTS+ when (usesLLVM $ configFlags local) installLLVM+ where+ target = datadir $ L.absoluteInstallDirs pkg local copy++ installStdLib = do+ putStrLn $ "Installing libraries in " ++ target+ makeInstall "lib" target+ when (usesEffects $ configFlags local) $ makeInstall "effects" target+ makeInstall "javascript" target++ installRTS = do+ let target' = target </> "rts"+ putStrLn $ "Installing run time system in " ++ target'+ makeInstall "rts" target'++ installLLVM = do+ let target' = target </> "llvm"+ putStrLn $ "Installing LLVM library in " ++ target+ makeInstall "llvm" target'++ makeInstall src target =+ make verbosity [ "-C", src, "install" , "TARGET=" ++ target, "IDRIS=" ++ idrisCmd local]++-- -----------------------------------------------------------------------------+-- Main+ -- Install libraries during both copy and install -- See http://hackage.haskell.org/trac/hackage/ticket/718-main = do- defaultMainWithHooks $ simpleUserHooks- { postCopy = \ _ flags pkg lbi -> do- let verb = S.fromFlag $ S.copyVerbosity flags- let withoutEffects = noEffectsFlag $ configFlags lbi- installStdLib pkg lbi withoutEffects verb- (S.fromFlag $ S.copyDest flags)- installJavaPom pkg lbi verb - (S.fromFlag $ S.copyDest flags)- (pkgVersion . package $ localPkgDescr lbi)- when (llvmFlag $ configFlags lbi) - (installLLVMLib verb pkg lbi (S.fromFlag $ S.copyDest flags))- , postInst = \ _ flags pkg lbi -> do- let verb = (S.fromFlag $ S.installVerbosity flags)- let withoutEffects = noEffectsFlag $ configFlags lbi- installStdLib pkg lbi withoutEffects verb- NoCopyDest- installJavaPom pkg lbi verb - NoCopyDest - (pkgVersion . package $ localPkgDescr lbi)- when (llvmFlag $ configFlags lbi) - (installLLVMLib verb pkg lbi NoCopyDest)- , postConf = \ _ flags _ lbi -> do- removeLibIdris lbi (S.fromFlag $ S.configVerbosity flags)- preparePoms . pkgVersion . package $ localPkgDescr lbi- , postClean = \ _ flags _ _ -> do- let verb = S.fromFlag $ S.cleanVerbosity flags- cleanStdLib verb- cleanLLVMLib verb- cleanJavaPom verb- , postBuild = \ _ flags _ lbi -> do- let verb = S.fromFlag $ S.buildVerbosity flags- when (llvmFlag $ configFlags lbi) (buildLLVMLib verb)- let withoutEffects = noEffectsFlag $ configFlags lbi- checkStdLib lbi withoutEffects verb- }+main = defaultMainWithHooks $ simpleUserHooks+ { postClean = idrisClean+ , postConf = idrisConfigure+ , postBuild = idrisBuild+ , postCopy = \_ flags pkg local ->+ idrisInstall (S.fromFlag $ S.copyVerbosity flags)+ (S.fromFlag $ S.copyDest flags) pkg local+ , postInst = \_ flags pkg local ->+ idrisInstall (S.fromFlag $ S.installVerbosity flags)+ NoCopyDest pkg local+ }
effects/Effects.idr view
@@ -79,8 +79,13 @@ updateResTy : (xs : List EFFECT) -> EffElem e a xs -> e a b t -> List EFFECT updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs-updateResTy (x :: xs) (There p) n = x :: updateResTy xs p n+updateResTy (x :: xs) (There p) n = x :: updateResTy xs p n +updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type -> + List EFFECT+updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs+updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b+ infix 5 :::, :-, := data LRes : lbl -> Type -> Type where@@ -111,6 +116,15 @@ new : Handler e m => res -> EffM m (MkEff res e :: xs) (MkEff res' e :: xs') a -> EffM m xs xs' a+ test : (prf : EffElem e (Either l r) xs) ->+ EffM m (updateResTyImm xs prf l) xs' t ->+ EffM m (updateResTyImm xs prf r) xs' t ->+ EffM m xs xs' t+ test_lbl : {x : lbl} ->+ (prf : EffElem e (LRes x (Either l r)) xs) ->+ EffM m (updateResTyImm xs prf (LRes x l)) xs' t ->+ EffM m (updateResTyImm xs prf (LRes x r)) xs' t ->+ EffM m xs xs' t catch : Catchable m err => EffM m xs xs' a -> (err -> EffM m xs xs' a) -> EffM m xs xs' a@@ -119,20 +133,41 @@ -- Eff : List (EFFECT m) -> Type -> Type implicit-lift' : {default tactics { applyTactic findSubList 100; solve; }+lift' : {default tactics { applyTactic findSubList 20; solve; } prf : SubList ys xs} -> EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t lift' {prf} e = lift prf e implicit effect' : {a, b: _} -> {e : Effect} ->- {default tactics { applyTactic findEffElem 100; solve; } + {default tactics { applyTactic findEffElem 20; solve; } prf : EffElem e a xs} -> (eff : e a b t) -> EffM m xs (updateResTy xs prf eff) t effect' {prf} e = effect prf e +data WrapEffM : (m : Type -> Type) ->+ List EFFECT -> List EFFECT -> Type -> Type where+ WEffM : EffM m xs xs' t -> WrapEffM m xs xs' t +-- wrap subprograms to prevent lifting (need to guarantee same effects as+-- parent!)++test_lbl' : {x : lbl} ->+ {default tactics { applyTactic findEffElem 20; solve; }+ prf : EffElem e (LRes x (Either l r)) xs} ->+ WrapEffM m (updateResTyImm xs prf (LRes x l)) xs' t ->+ WrapEffM m (updateResTyImm xs prf (LRes x r)) xs' t ->+ EffM m xs xs' t+test_lbl' {prf} (WEffM l) (WEffM r) = test_lbl prf l r++test' : {default tactics { applyTactic findEffElem 20; solve; }+ prf : EffElem e (Either l r) xs} ->+ EffM m (updateResTyImm xs prf l) xs' t ->+ EffM m (updateResTyImm xs prf r) xs' t ->+ EffM m xs xs' t+test' {prf} l r = test prf l r+ -- for 'do' notation return : a -> EffM m xs xs a@@ -164,6 +199,29 @@ execEff (val :: env) (There p) eff k = execEff env p eff (\env', v => k (val :: env') v) +private+testEff : Env m xs -> (p : EffElem e (Either l r) xs) ->+ (Env m (updateResTyImm xs p l) -> m b) ->+ (Env m (updateResTyImm xs p r) -> m b) ->+ m b+testEff (Left err :: env) Here lk rk = lk (err :: env)+testEff (Right ok :: env) Here lk rk = rk (ok :: env)+testEff (val :: env) (There p) lk rk+ = testEff env p (\envk => lk (val :: envk))+ (\envk => rk (val :: envk)) ++private+testEffLbl : {x : lbl} ->+ Env m xs -> (p : EffElem e (LRes x (Either l r)) xs) ->+ (Env m (updateResTyImm xs p (LRes x l)) -> m b) ->+ (Env m (updateResTyImm xs p (LRes x r)) -> m b) ->+ m b+testEffLbl ((lbl := Left err) :: env) Here lk rk = lk ((lbl := err) :: env)+testEffLbl ((lbl := Right ok) :: env) Here lk rk = rk ((lbl := ok) :: env)+testEffLbl (val :: env) (There p) lk rk+ = testEffLbl env p (\envk => lk (val :: envk))+ (\envk => rk (val :: envk)) + -- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state -- updates can be propagated even through failing computations? @@ -178,6 +236,10 @@ eff env (new r prog) k = let env' = r :: env in eff env' prog (\(v :: envk), p' => k envk p')+eff env (test prf l r) k+ = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k)+eff env (test_lbl prf l r) k+ = testEffLbl env prf (\envk => eff envk l k) (\envk => eff envk r k) eff env (catch prog handler) k = catch (eff env prog k) (\e => eff env (handler e) k)
effects/Makefile view
@@ -1,13 +1,14 @@+IDRIS := idris -check: .PHONY+build: .PHONY $(IDRIS) --build effects.ipkg -recheck: clean check+clean: .PHONY+ $(IDRIS) --clean effects.ipkg install: $(IDRIS) --install effects.ipkg -clean: .PHONY- $(IDRIS) --clean effects.ipkg+rebuild: clean build .PHONY:
idris.cabal view
@@ -1,5 +1,5 @@ Name: idris-Version: 0.9.9.2+Version: 0.9.9.3 License: BSD3 License-file: LICENSE Author: Edwin Brady@@ -14,7 +14,8 @@ Dependent types allow types to be predicated on values, meaning that some aspects of a program's behaviour can be specified precisely in the type. The language is closely- related to Epigram and Agda. There is a tutorial at <http://www.idris-lang.org/documentation>.+ related to Epigram and Agda. There is a tutorial at+ <http://www.idris-lang.org/documentation>. Features include: . * Full dependent types with dependent pattern matching@@ -43,38 +44,60 @@ Cabal-Version: >= 1.6 - Build-type: Custom --Data-files: rts/idris_rts.h rts/idris_gc.h rts/idris_stdfgn.h- rts/idris_main.c rts/idris_gmp.h+Data-files: jsrts/Runtime-browser.js+ jsrts/Runtime-common.js+ jsrts/Runtime-node.js+ jsrts/jsbn/jsbn.js+ jsrts/jsbn/LICENSE+ rts/idris_gc.h+ rts/idris_gmp.h+ rts/idris_main.c+ rts/idris_rts.h+ rts/idris_stdfgn.h rts/libtest.c- js/Runtime-common.js- js/Runtime-node.js- js/Runtime-browser.js-Extra-source-files: lib/Makefile lib/*.idr lib/Prelude/*.idr- lib/Network/*.idr lib/Control/*.idr- lib/Control/Monad/*.idr lib/Language/*.idr- lib/Language/Reflection/*.idr- lib/System/Concurrency/*.idr- lib/Data/*.idr lib/Debug/*.idr++Extra-source-files:+ Makefile+ config.mk++ rts/*.c+ rts/*.h+ rts/Makefile++ lib/base.ipkg+ lib/*.idr+ lib/Control/*.idr+ lib/Control/Monad/*.idr+ lib/Data/*.idr lib/Data/Vect/*.idr+ lib/Debug/*.idr lib/Decidable/*.idr- tutorial/examples/*.idr lib/base.ipkg- effects/Makefile effects/*.idr effects/Effect/*.idr+ lib/Language/*.idr+ lib/Language/Reflection/*.idr+ lib/Makefile+ lib/Network/*.idr+ lib/Prelude/*.idr+ lib/System/Concurrency/*.idr++ effects/Makefile effects/effects.ipkg- javascript/Makefile- javascript/JavaScript/*.idr+ effects/Effect/*.idr+ effects/*.idr++ java/*.xml+ javascript/*.idr+ javascript/JavaScript/*.idr+ javascript/Makefile javascript/javascript.ipkg- config.mk- rts/*.c rts/*.h rts/Makefile- llvm/*.c llvm/Makefile- js/*.js- java/*.xml - Makefile+ llvm/*.c+ llvm/Makefile++ tutorial/examples/*.idr+ test/Makefile test/runtest.pl test/reg001/run@@ -137,6 +160,18 @@ test/reg020/run test/reg020/*.idr test/reg020/expected+ test/reg021/run+ test/reg021/*.idr+ test/reg021/expected+ test/reg022/run+ test/reg022/*.idr+ test/reg022/expected+ test/reg023/run+ test/reg023/*.idr+ test/reg023/expected+ test/reg024/run+ test/reg024/*.idr+ test/reg024/expected test/test001/run test/test001/*.idr test/test001/expected@@ -233,77 +268,149 @@ test/test030/run test/test030/*.idr test/test030/expected-+ test/test031/run+ test/test031/*.idr+ test/test031/expected source-repository head type: git location: git://github.com/edwinb/Idris-dev.git -Flag NoEffects- Description: Do not build the effects package- Default: False+Flag Effects+ Description: Build the effects package+ Default: True Flag LLVM Description: Build the LLVM backend Default: True manual: True -Executable idris- Main-is: Main.hs- hs-source-dirs: src- Other-modules: Core.TT, Core.Evaluate, Core.Execute, Core.Typecheck,- Core.ProofShell, Core.ProofState, Core.CoreParser,- Core.ShellParser, Core.Unify, Core.Elaborate,- Core.CaseTree, Core.Constraints,+Executable idris+ Main-is: Main.hs+ hs-source-dirs: src+ Other-modules:+ Core.CaseTree+ , Core.Constraints+ , Core.CoreParser+ , Core.Elaborate+ , Core.Evaluate+ , Core.Execute+ , Core.ProofShell+ , Core.ProofState+ , Core.ShellParser+ , Core.TT+ , Core.Typecheck+ , Core.Unify - Idris.AbsSyntax, Idris.AbsSyntaxTree, Idris.Colours,- Idris.Parser, Idris.Help, Idris.IdeSlave, Idris.REPL,- Idris.REPLParser, Idris.ElabDecls, Idris.Error,- Idris.Delaborate, Idris.Primitives, Idris.Imports,- Idris.Prover, Idris.ElabTerm,- Idris.Coverage, Idris.IBC, Idris.Unlit,- Idris.DataOpts, Idris.Transforms, Idris.DSL,- Idris.UnusedArgs, Idris.Docs, Idris.Completion,- Idris.PartialEval, Idris.Providers, Idris.Chaser,- Idris.Inliner,+ , Idris.AbsSyntax+ , Idris.AbsSyntaxTree+ , Idris.Chaser+ , Idris.Colours+ , Idris.Completion+ , Idris.Coverage+ , Idris.DSL+ , Idris.DataOpts+ , Idris.Delaborate+ , Idris.Docs+ , Idris.ElabDecls+ , Idris.ElabTerm+ , Idris.Error+ , Idris.Help+ , Idris.IBC+ , Idris.IdeSlave+ , Idris.Imports+ , Idris.Inliner+ , Idris.Parser+ , Idris.ParseHelpers+ , Idris.ParseOps+ , Idris.ParseExpr+ , Idris.ParseData+ , Idris.PartialEval+ , Idris.Primitives+ , Idris.Prover+ , Idris.Providers+ , Idris.REPL+ , Idris.REPLParser+ , Idris.Transforms+ , Idris.Unlit+ , Idris.UnusedArgs - Util.Pretty, Util.System, Util.DynamicLinker,- Pkg.Package, Pkg.PParser,+ , IRTS.BCImp+ , IRTS.Bytecode+ , IRTS.CodegenC+ , IRTS.CodegenCommon+ , IRTS.CodegenJava+ , IRTS.CodegenJavaScript+ , IRTS.Compiler+ , IRTS.Defunctionalise+ , IRTS.DumpBC+ , IRTS.Inliner+ , IRTS.Java.ASTBuilding+ , IRTS.Java.JTypes+ , IRTS.Java.Mangling+ , IRTS.LParser+ , IRTS.Lang+ , IRTS.Simplified - IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified,- IRTS.CodegenC, IRTS.Defunctionalise, IRTS.Inliner,- IRTS.Compiler, IRTS.CodegenJava, IRTS.Java.ASTBuilding,- IRTS.Java.JTypes, IRTS.Java.Mangling, IRTS.BCImp,- IRTS.CodegenJavaScript,- IRTS.CodegenCommon, IRTS.DumpBC+ , Util.Pretty+ , Util.System+ , Util.DynamicLinker - Paths_idris+ , Pkg.Package+ , Pkg.PParser - Build-depends: base>=4 && <5, parsec>=3, mtl, Cabal,- haskeline>=0.7, split, directory>=1.2,- time>=1.4,- containers, process, transformers, filepath,- directory, binary, bytestring, text, pretty,- language-java>=0.2.2, libffi,- vector, vector-binary-instances, ansi-terminal,- utf8-string, unordered-containers, parsers>=0.9, trifecta>=1.1+ -- Auto Generated+ Paths_idris - Extensions: MultiParamTypeClasses, FunctionalDependencies,- FlexibleInstances, TemplateHaskell- ghc-prof-options: -auto-all -caf-all- ghc-options: -rtsopts- if os(linux)- cpp-options: -DLINUX- build-depends: unix- if os(darwin)- cpp-options: -DMACOSX- build-depends: unix- if os(windows)- cpp-options: -DWINDOWS- build-depends: Win32- if flag(LLVM)- other-modules: IRTS.CodegenLLVM- cpp-options: -DIDRIS_LLVM- build-depends: llvm-general==3.3.8.*, llvm-general-pure==3.3.8.*- else- other-modules: Util.LLVMStubs+ Build-depends: base >=4 && <5+ , Cabal+ , ansi-terminal+ , ansi-wl-pprint+ , binary+ , bytestring+ , containers+ , directory+ , directory >= 1.2+ , filepath+ , haskeline >= 0.7+ , language-java >= 0.2.2+ , libffi+ , mtl+ , parsec >= 3+ , parsers == 0.9+ , pretty+ , process+ , split+ , text+ , time >= 1.4+ , transformers+ , trifecta == 1.1+ , unordered-containers+ , utf8-string+ , vector+ , vector-binary-instances++ Extensions: MultiParamTypeClasses+ , FunctionalDependencies+ , FlexibleInstances+ , TemplateHaskell++ ghc-prof-options: -auto-all -caf-all+ ghc-options: -rtsopts++ if os(linux)+ cpp-options: -DLINUX+ build-depends: unix+ if os(darwin)+ cpp-options: -DMACOSX+ build-depends: unix+ if os(windows)+ cpp-options: -DWINDOWS+ build-depends: Win32+ if flag(LLVM)+ other-modules: IRTS.CodegenLLVM+ cpp-options: -DIDRIS_LLVM+ build-depends: llvm-general == 3.3.8.*+ , llvm-general-pure == 3.3.8.*+ else+ other-modules: Util.LLVMStubs
javascript/Makefile view
@@ -1,13 +1,14 @@+IDRIS := idris -check: .PHONY+build: .PHONY $(IDRIS) --build javascript.ipkg -recheck: clean check- install: $(IDRIS) --install javascript.ipkg clean: .PHONY $(IDRIS) --clean javascript.ipkg++rebuild: clean build .PHONY:
− js/Runtime-browser.js
@@ -1,3 +0,0 @@-var __IDRRT__print = function(s) {- console.log(s);-};
− js/Runtime-common.js
@@ -1,400 +0,0 @@-/** @constructor */-var __IDRRT__Type = function(type) {- this.type = type;-};--var __IDRRT__Int = new __IDRRT__Type('Int');-var __IDRRT__Char = new __IDRRT__Type('Char');-var __IDRRT__String = new __IDRRT__Type('String');-var __IDRRT__Integer = new __IDRRT__Type('Integer');-var __IDRRT__Float = new __IDRRT__Type('Float');-var __IDRRT__Ptr = new __IDRRT__Type('Pointer');-var __IDRRT__Forgot = new __IDRRT__Type('Forgot');---/** @constructor */-var __IDRRT__Tailcall = function(f) { this.f = f };--var __IDRRT__ffiWrap = function(fid) {- return function(){- var res = fid;- var i = 0;- var arg;- while (res instanceof __IDRRT__Con){- arg = arguments[i];- res = __IDRRT__tailcall(function(){- return __IDR__mAPPLY0(res, arg);- });- ++i;- }- return res;- }-};--/** @constructor */-var __IDRRT__Con = function(tag,vars) {- this.tag = tag;- this.vars = vars;-};--var __IDRRT__tailcall = function(f) {- var __f = f;- var ret;- while (__f) {- f = __f;- __f = null;- ret = f();-- if (ret instanceof __IDRRT__Tailcall) {- __f = ret.f;- } else {- return ret;- }- }-};--/*- BigInteger Javascript code taken from:- https://github.com/peterolson-*/-var __IDRRT__bigInt = (function () {- var base = 10000000, logBase = 7;- var sign = {- positive: false,- negative: true- };-- var normalize = function (first, second) {- var a = first.value, b = second.value;- var length = a.length > b.length ? a.length : b.length;- for (var i = 0; i < length; i++) {- a[i] = a[i] || 0;- b[i] = b[i] || 0;- }- for (var i = length - 1; i >= 0; i--) {- if (a[i] === 0 && b[i] === 0) {- a.pop();- b.pop();- } else break;- }- if (!a.length) a = [0], b = [0];- first.value = a;- second.value = b;- };-- var parse = function (text, first) {- if (typeof text === "object") return text;- text += "";- var s = sign.positive, value = [];- if (text[0] === "-") {- s = sign.negative;- text = text.slice(1);- }- var text = text.split("e");- if (text.length > 2) throw new Error("Invalid integer");- if (text[1]) {- var exp = text[1];- if (exp[0] === "+") exp = exp.slice(1);- exp = parse(exp);- if (exp.lesser(0)) throw new Error("Cannot include negative exponent part for integers");- while (exp.notEquals(0)) {- text[0] += "0";- exp = exp.prev();- }- }- text = text[0];- if (text === "-0") text = "0";- var isValid = /^([0-9][0-9]*)$/.test(text);- if (!isValid) throw new Error("Invalid integer");- while (text.length) {- var divider = text.length > logBase ? text.length - logBase : 0;- value.push(+text.slice(divider));- text = text.slice(0, divider);- }- var val = bigInt(value, s);- if (first) normalize(first, val);- return val;- };-- var goesInto = function (a, b) {- var a = bigInt(a, sign.positive), b = bigInt(b, sign.positive);- if (a.equals(0)) throw new Error("Cannot divide by 0");- var n = 0;- do {- var inc = 1;- var c = bigInt(a.value, sign.positive), t = c.times(10);- while (t.lesser(b)) {- c = t;- inc *= 10;- t = t.times(10);- }- while (c.lesserOrEquals(b)) {- b = b.minus(c);- n += inc;- }- } while (a.lesserOrEquals(b));-- return {- remainder: b.value,- result: n- };- };-- var bigInt = function (value, s) {- var self = {- value: value,- sign: s- };- var o = {- value: value,- sign: s,- negate: function (m) {- var first = m || self;- return bigInt(first.value, !first.sign);- },- abs: function (m) {- var first = m || self;- return bigInt(first.value, sign.positive);- },- add: function (n, m) {- var s, first = self, second;- if (m) (first = parse(n)) && (second = parse(m));- else second = parse(n, first);- s = first.sign;- if (first.sign !== second.sign) {- first = bigInt(first.value, sign.positive);- second = bigInt(second.value, sign.positive);- return s === sign.positive ?- o.subtract(first, second) :- o.subtract(second, first);- }- normalize(first, second);- var a = first.value, b = second.value;- var result = [],- carry = 0;- for (var i = 0; i < a.length || carry > 0; i++) {- var sum = (a[i] || 0) + (b[i] || 0) + carry;- carry = sum >= base ? 1 : 0;- sum -= carry * base;- result.push(sum);- }- return bigInt(result, s);- },- plus: function (n, m) {- return o.add(n, m);- },- subtract: function (n, m) {- var first = self, second;- if (m) (first = parse(n)) && (second = parse(m));- else second = parse(n, first);- if (first.sign !== second.sign) return o.add(first, o.negate(second));- if (first.sign === sign.negative) return o.subtract(o.negate(second), o.negate(first));- if (o.compare(first, second) === -1) return o.negate(o.subtract(second, first));- var a = first.value, b = second.value;- var result = [],- borrow = 0;- for (var i = 0; i < a.length; i++) {- a[i] -= borrow;- borrow = a[i] < b[i] ? 1 : 0;- var minuend = (borrow * base) + a[i] - b[i];- result.push(minuend);- }- return bigInt(result, sign.positive);- },- minus: function (n, m) {- return o.subtract(n, m);- },- multiply: function (n, m) {- var s, first = self, second;- if (m) (first = parse(n)) && (second = parse(m));- else second = parse(n, first);- s = first.sign !== second.sign;- var a = first.value, b = second.value;- var resultSum = [];- for (var i = 0; i < a.length; i++) {- resultSum[i] = [];- var j = i;- while (j--) {- resultSum[i].push(0);- }- }- var carry = 0;- for (var i = 0; i < a.length; i++) {- var x = a[i];- for (var j = 0; j < b.length || carry > 0; j++) {- var y = b[j];- var product = y ? (x * y) + carry : carry;- carry = product > base ? Math.floor(product / base) : 0;- product -= carry * base;- resultSum[i].push(product);- }- }- var max = -1;- for (var i = 0; i < resultSum.length; i++) {- var len = resultSum[i].length;- if (len > max) max = len;- }- var result = [], carry = 0;- for (var i = 0; i < max || carry > 0; i++) {- var sum = carry;- for (var j = 0; j < resultSum.length; j++) {- sum += resultSum[j][i] || 0;- }- carry = sum > base ? Math.floor(sum / base) : 0;- sum -= carry * base;- result.push(sum);- }- return bigInt(result, s);- },- times: function (n, m) {- return o.multiply(n, m);- },- divmod: function (n, m) {- var s, first = self, second;- if (m) (first = parse(n)) && (second = parse(m));- else second = parse(n, first);- s = first.sign !== second.sign;- if (bigInt(first.value, first.sign).equals(0)) return {- quotient: bigInt([0], sign.positive),- remainder: bigInt([0], sign.positive)- };- if (second.equals(0)) throw new Error("Cannot divide by zero");- var a = first.value, b = second.value;- var result = [], remainder = [];- for (var i = a.length - 1; i >= 0; i--) {- var n = [a[i]].concat(remainder);- var quotient = goesInto(b, n);- result.push(quotient.result);- remainder = quotient.remainder;- }- result.reverse();- return {- quotient: bigInt(result, s),- remainder: bigInt(remainder, first.sign)- };- },- divide: function (n, m) {- return o.divmod(n, m).quotient;- },- over: function (n, m) {- return o.divide(n, m);- },- mod: function (n, m) {- return o.divmod(n, m).remainder;- },- pow: function (n, m) {- var first = self, second;- if (m) (first = parse(n)) && (second = parse(m));- else second = parse(n, first);- var a = first, b = second;- if (b.lesser(0)) return ZERO;- if (b.equals(0)) return ONE;- var result = bigInt(a.value, a.sign);-- if (b.mod(2).equals(0)) {- var c = result.pow(b.over(2));- return c.times(c);- } else {- return result.times(result.pow(b.minus(1)));- }- },- next: function (m) {- var first = m || self;- return o.add(first, 1);- },- prev: function (m) {- var first = m || self;- return o.subtract(first, 1);- },- compare: function (n, m) {- var first = self, second;- if (m) (first = parse(n)) && (second = parse(m, first));- else second = parse(n, first);- normalize(first, second);- if (first.value.length === 1 && second.value.length === 1 && first.value[0] === 0 && second.value[0] === 0) return 0;- if (second.sign !== first.sign) return first.sign === sign.positive ? 1 : -1;- var multiplier = first.sign === sign.positive ? 1 : -1;- var a = first.value, b = second.value;- for (var i = a.length - 1; i >= 0; i--) {- if (a[i] > b[i]) return 1 * multiplier;- if (b[i] > a[i]) return -1 * multiplier;- }- return 0;- },- compareAbs: function (n, m) {- var first = self, second;- if (m) (first = parse(n)) && (second = parse(m, first));- else second = parse(n, first);- first.sign = second.sign = sign.positive;- return o.compare(first, second);- },- equals: function (n, m) {- return o.compare(n, m) === 0;- },- notEquals: function (n, m) {- return !o.equals(n, m);- },- lesser: function (n, m) {- return o.compare(n, m) < 0;- },- greater: function (n, m) {- return o.compare(n, m) > 0;- },- greaterOrEquals: function (n, m) {- return o.compare(n, m) >= 0;- },- lesserOrEquals: function (n, m) {- return o.compare(n, m) <= 0;- },- isPositive: function (m) {- var first = m || self;- return first.sign === sign.positive;- },- isNegative: function (m) {- var first = m || self;- return first.sign === sign.negative;- },- isEven: function (m) {- var first = m || self;- return first.value[0] % 2 === 0;- },- isOdd: function (m) {- var first = m || self;- return first.value[0] % 2 === 1;- },- toString: function (m) {- var first = m || self;- var str = "", len = first.value.length;- while (len--) {- str += (base.toString() + first.value[len]).slice(-logBase);- }- while (str[0] === "0") {- str = str.slice(1);- }- if (!str.length) str = "0";- var s = first.sign === sign.positive ? "" : "-";- return s + str;- },- toJSNumber: function (m) {- return +o.toString(m);- },- valueOf: function (m) {- return o.toJSNumber(m);- }- };- return o;- };-- var ZERO = bigInt([0], sign.positive);- var ONE = bigInt([1], sign.positive);- var MINUS_ONE = bigInt([1], sign.negative);-- var fnReturn = function (a) {- if (typeof a === "undefined") return ZERO;- return parse(a);- };- fnReturn.zero = ZERO;- fnReturn.one = ONE;- fnReturn.minusOne = MINUS_ONE;- return fnReturn;-})();
− js/Runtime-node.js
@@ -1,6 +0,0 @@-var __IDRRT__print = (function() {- var util = require('util');- return function(s) {- util.print(s);- };-})();
+ jsrts/Runtime-browser.js view
@@ -0,0 +1,3 @@+var __IDRRT__print = function(s) {+ console.log(s);+};
+ jsrts/Runtime-common.js view
@@ -0,0 +1,51 @@+var __IDRRT__ZERO = __IDRRT__bigInt("0");+var __IDRRT__ONE = __IDRRT__bigInt("1");++/** @constructor */+var __IDRRT__Type = function(type) {+ this.type = type;+};++var __IDRRT__Int = new __IDRRT__Type('Int');+var __IDRRT__Char = new __IDRRT__Type('Char');+var __IDRRT__String = new __IDRRT__Type('String');+var __IDRRT__Integer = new __IDRRT__Type('Integer');+var __IDRRT__Float = new __IDRRT__Type('Float');+var __IDRRT__Ptr = new __IDRRT__Type('Pointer');+var __IDRRT__Forgot = new __IDRRT__Type('Forgot');+++/** @constructor */+var __IDRRT__Cont = function(k) {+ this.k = k;+};++var __IDRRT__ffiWrap = function(fid) {+ return function(){+ var res = fid;+ var i = 0;+ var arg;+ while (res instanceof __IDRRT__Con){+ arg = arguments[i];+ res = __IDRRT__tailcall(function(){+ return __IDR__mAPPLY0(res, arg);+ });+ ++i;+ }+ return res;+ }+};++/** @constructor */+var __IDRRT__Con = function(tag,vars) {+ this.tag = tag;+ this.vars = vars;+};++var __IDRRT__tailcall = function(k) {+ var ret = k();+ while (ret instanceof __IDRRT__Cont)+ ret = ret.k();++ return ret;+};
+ jsrts/Runtime-node.js view
@@ -0,0 +1,6 @@+var __IDRRT__print = (function() {+ var util = require('util');+ return function(s) {+ util.print(s);+ };+})();
+ jsrts/jsbn/LICENSE view
@@ -0,0 +1,40 @@+Licensing+---------++This software is covered under the following copyright:++/*+ * Copyright (c) 2003-2005 Tom Wu+ * All Rights Reserved.+ *+ * Permission is hereby granted, free of charge, to any person obtaining+ * a copy of this software and associated documentation files (the+ * "Software"), to deal in the Software without restriction, including+ * without limitation the rights to use, copy, modify, merge, publish,+ * distribute, sublicense, and/or sell copies of the Software, and to+ * permit persons to whom the Software is furnished to do so, subject to+ * the following conditions:+ *+ * The above copyright notice and this permission notice shall be+ * included in all copies or substantial portions of the Software.+ *+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND, + * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY + * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. + *+ * IN NO EVENT SHALL TOM WU BE LIABLE FOR ANY SPECIAL, INCIDENTAL,+ * INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND, OR ANY DAMAGES WHATSOEVER+ * RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER OR NOT ADVISED OF+ * THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF LIABILITY, ARISING OUT+ * OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.+ *+ * In addition, the following condition applies:+ *+ * All redistributions must retain an intact copy of this copyright notice+ * and disclaimer.+ */++Address all questions regarding this license to:++ Tom Wu+ tjw@cs.Stanford.EDU
+ jsrts/jsbn/jsbn.js view
@@ -0,0 +1,1235 @@+var __IDRRT__bigInt = (function() {+// Copyright (c) 2005 Tom Wu+// All Rights Reserved.+// See "LICENSE" for details.++// Basic JavaScript BN library - subset useful for RSA encryption.++// Bits per digit+var dbits;++// JavaScript engine analysis+var canary = 0xdeadbeefcafe;+var j_lm = ((canary&0xffffff)==0xefcafe);++// (public) Constructor+function BigInteger(a,b,c) {+ if(a != null)+ if("number" == typeof a) this.fromNumber(a,b,c);+ else if(b == null && "string" != typeof a) this.fromString(a,256);+ else this.fromString(a,b);+}++// return new, unset BigInteger+function nbi() { return new BigInteger(null); }++// am: Compute w_j += (x*this_i), propagate carries,+// c is initial carry, returns final carry.+// c < 3*dvalue, x < 2*dvalue, this_i < dvalue+// We need to select the fastest one that works in this environment.++// am1: use a single mult and divide to get the high bits,+// max digit bits should be 26 because+// max internal value = 2*dvalue^2-2*dvalue (< 2^53)+function am1(i,x,w,j,c,n) {+ while(--n >= 0) {+ var v = x*this[i++]+w[j]+c;+ c = Math.floor(v/0x4000000);+ w[j++] = v&0x3ffffff;+ }+ return c;+}+// am2 avoids a big mult-and-extract completely.+// Max digit bits should be <= 30 because we do bitwise ops+// on values up to 2*hdvalue^2-hdvalue-1 (< 2^31)+function am2(i,x,w,j,c,n) {+ var xl = x&0x7fff, xh = x>>15;+ while(--n >= 0) {+ var l = this[i]&0x7fff;+ var h = this[i++]>>15;+ var m = xh*l+h*xl;+ l = xl*l+((m&0x7fff)<<15)+w[j]+(c&0x3fffffff);+ c = (l>>>30)+(m>>>15)+xh*h+(c>>>30);+ w[j++] = l&0x3fffffff;+ }+ return c;+}+// Alternately, set max digit bits to 28 since some+// browsers slow down when dealing with 32-bit numbers.+function am3(i,x,w,j,c,n) {+ var xl = x&0x3fff, xh = x>>14;+ while(--n >= 0) {+ var l = this[i]&0x3fff;+ var h = this[i++]>>14;+ var m = xh*l+h*xl;+ l = xl*l+((m&0x3fff)<<14)+w[j]+c;+ c = (l>>28)+(m>>14)+xh*h;+ w[j++] = l&0xfffffff;+ }+ return c;+}+var in_browser = typeof navigator !== "undefined"+if(in_browser && j_lm && (navigator.appName == "Microsoft Internet Explorer")) {+ BigInteger.prototype.am = am2;+ dbits = 30;+}+else if(in_browser && j_lm && (navigator.appName != "Netscape")) {+ BigInteger.prototype.am = am1;+ dbits = 26;+}+else { // Mozilla/Netscape seems to prefer am3+ BigInteger.prototype.am = am3;+ dbits = 28;+}++BigInteger.prototype.DB = dbits;+BigInteger.prototype.DM = ((1<<dbits)-1);+BigInteger.prototype.DV = (1<<dbits);++var BI_FP = 52;+BigInteger.prototype.FV = Math.pow(2,BI_FP);+BigInteger.prototype.F1 = BI_FP-dbits;+BigInteger.prototype.F2 = 2*dbits-BI_FP;++// Digit conversions+var BI_RM = "0123456789abcdefghijklmnopqrstuvwxyz";+var BI_RC = new Array();+var rr,vv;+rr = "0".charCodeAt(0);+for(vv = 0; vv <= 9; ++vv) BI_RC[rr++] = vv;+rr = "a".charCodeAt(0);+for(vv = 10; vv < 36; ++vv) BI_RC[rr++] = vv;+rr = "A".charCodeAt(0);+for(vv = 10; vv < 36; ++vv) BI_RC[rr++] = vv;++function int2char(n) { return BI_RM.charAt(n); }+function intAt(s,i) {+ var c = BI_RC[s.charCodeAt(i)];+ return (c==null)?-1:c;+}++// (protected) copy this to r+function bnpCopyTo(r) {+ for(var i = this.t-1; i >= 0; --i) r[i] = this[i];+ r.t = this.t;+ r.s = this.s;+}++// (protected) set from integer value x, -DV <= x < DV+function bnpFromInt(x) {+ this.t = 1;+ this.s = (x<0)?-1:0;+ if(x > 0) this[0] = x;+ else if(x < -1) this[0] = x+this.DV;+ else this.t = 0;+}++// return bigint initialized to value+function nbv(i) { var r = nbi(); r.fromInt(i); return r; }++// (protected) set from string and radix+function bnpFromString(s,b) {+ var k;+ if(b == 16) k = 4;+ else if(b == 8) k = 3;+ else if(b == 256) k = 8; // byte array+ else if(b == 2) k = 1;+ else if(b == 32) k = 5;+ else if(b == 4) k = 2;+ else { this.fromRadix(s,b); return; }+ this.t = 0;+ this.s = 0;+ var i = s.length, mi = false, sh = 0;+ while(--i >= 0) {+ var x = (k==8)?s[i]&0xff:intAt(s,i);+ if(x < 0) {+ if(s.charAt(i) == "-") mi = true;+ continue;+ }+ mi = false;+ if(sh == 0)+ this[this.t++] = x;+ else if(sh+k > this.DB) {+ this[this.t-1] |= (x&((1<<(this.DB-sh))-1))<<sh;+ this[this.t++] = (x>>(this.DB-sh));+ }+ else+ this[this.t-1] |= x<<sh;+ sh += k;+ if(sh >= this.DB) sh -= this.DB;+ }+ if(k == 8 && (s[0]&0x80) != 0) {+ this.s = -1;+ if(sh > 0) this[this.t-1] |= ((1<<(this.DB-sh))-1)<<sh;+ }+ this.clamp();+ if(mi) BigInteger.ZERO.subTo(this,this);+}++// (protected) clamp off excess high words+function bnpClamp() {+ var c = this.s&this.DM;+ while(this.t > 0 && this[this.t-1] == c) --this.t;+}++// (public) return string representation in given radix+function bnToString(b) {+ if(this.s < 0) return "-"+this.negate().toString(b);+ var k;+ if(b == 16) k = 4;+ else if(b == 8) k = 3;+ else if(b == 2) k = 1;+ else if(b == 32) k = 5;+ else if(b == 4) k = 2;+ else return this.toRadix(b);+ var km = (1<<k)-1, d, m = false, r = "", i = this.t;+ var p = this.DB-(i*this.DB)%k;+ if(i-- > 0) {+ if(p < this.DB && (d = this[i]>>p) > 0) { m = true; r = int2char(d); }+ while(i >= 0) {+ if(p < k) {+ d = (this[i]&((1<<p)-1))<<(k-p);+ d |= this[--i]>>(p+=this.DB-k);+ }+ else {+ d = (this[i]>>(p-=k))&km;+ if(p <= 0) { p += this.DB; --i; }+ }+ if(d > 0) m = true;+ if(m) r += int2char(d);+ }+ }+ return m?r:"0";+}++// (public) -this+function bnNegate() { var r = nbi(); BigInteger.ZERO.subTo(this,r); return r; }++// (public) |this|+function bnAbs() { return (this.s<0)?this.negate():this; }++// (public) return + if this > a, - if this < a, 0 if equal+function bnCompareTo(a) {+ var r = this.s-a.s;+ if(r != 0) return r;+ var i = this.t;+ r = i-a.t;+ if(r != 0) return (this.s<0)?-r:r;+ while(--i >= 0) if((r=this[i]-a[i]) != 0) return r;+ return 0;+}++// returns bit length of the integer x+function nbits(x) {+ var r = 1, t;+ if((t=x>>>16) != 0) { x = t; r += 16; }+ if((t=x>>8) != 0) { x = t; r += 8; }+ if((t=x>>4) != 0) { x = t; r += 4; }+ if((t=x>>2) != 0) { x = t; r += 2; }+ if((t=x>>1) != 0) { x = t; r += 1; }+ return r;+}++// (public) return the number of bits in "this"+function bnBitLength() {+ if(this.t <= 0) return 0;+ return this.DB*(this.t-1)+nbits(this[this.t-1]^(this.s&this.DM));+}++// (protected) r = this << n*DB+function bnpDLShiftTo(n,r) {+ var i;+ for(i = this.t-1; i >= 0; --i) r[i+n] = this[i];+ for(i = n-1; i >= 0; --i) r[i] = 0;+ r.t = this.t+n;+ r.s = this.s;+}++// (protected) r = this >> n*DB+function bnpDRShiftTo(n,r) {+ for(var i = n; i < this.t; ++i) r[i-n] = this[i];+ r.t = Math.max(this.t-n,0);+ r.s = this.s;+}++// (protected) r = this << n+function bnpLShiftTo(n,r) {+ var bs = n%this.DB;+ var cbs = this.DB-bs;+ var bm = (1<<cbs)-1;+ var ds = Math.floor(n/this.DB), c = (this.s<<bs)&this.DM, i;+ for(i = this.t-1; i >= 0; --i) {+ r[i+ds+1] = (this[i]>>cbs)|c;+ c = (this[i]&bm)<<bs;+ }+ for(i = ds-1; i >= 0; --i) r[i] = 0;+ r[ds] = c;+ r.t = this.t+ds+1;+ r.s = this.s;+ r.clamp();+}++// (protected) r = this >> n+function bnpRShiftTo(n,r) {+ r.s = this.s;+ var ds = Math.floor(n/this.DB);+ if(ds >= this.t) { r.t = 0; return; }+ var bs = n%this.DB;+ var cbs = this.DB-bs;+ var bm = (1<<bs)-1;+ r[0] = this[ds]>>bs;+ for(var i = ds+1; i < this.t; ++i) {+ r[i-ds-1] |= (this[i]&bm)<<cbs;+ r[i-ds] = this[i]>>bs;+ }+ if(bs > 0) r[this.t-ds-1] |= (this.s&bm)<<cbs;+ r.t = this.t-ds;+ r.clamp();+}++// (protected) r = this - a+function bnpSubTo(a,r) {+ var i = 0, c = 0, m = Math.min(a.t,this.t);+ while(i < m) {+ c += this[i]-a[i];+ r[i++] = c&this.DM;+ c >>= this.DB;+ }+ if(a.t < this.t) {+ c -= a.s;+ while(i < this.t) {+ c += this[i];+ r[i++] = c&this.DM;+ c >>= this.DB;+ }+ c += this.s;+ }+ else {+ c += this.s;+ while(i < a.t) {+ c -= a[i];+ r[i++] = c&this.DM;+ c >>= this.DB;+ }+ c -= a.s;+ }+ r.s = (c<0)?-1:0;+ if(c < -1) r[i++] = this.DV+c;+ else if(c > 0) r[i++] = c;+ r.t = i;+ r.clamp();+}++// (protected) r = this * a, r != this,a (HAC 14.12)+// "this" should be the larger one if appropriate.+function bnpMultiplyTo(a,r) {+ var x = this.abs(), y = a.abs();+ var i = x.t;+ r.t = i+y.t;+ while(--i >= 0) r[i] = 0;+ for(i = 0; i < y.t; ++i) r[i+x.t] = x.am(0,y[i],r,i,0,x.t);+ r.s = 0;+ r.clamp();+ if(this.s != a.s) BigInteger.ZERO.subTo(r,r);+}++// (protected) r = this^2, r != this (HAC 14.16)+function bnpSquareTo(r) {+ var x = this.abs();+ var i = r.t = 2*x.t;+ while(--i >= 0) r[i] = 0;+ for(i = 0; i < x.t-1; ++i) {+ var c = x.am(i,x[i],r,2*i,0,1);+ if((r[i+x.t]+=x.am(i+1,2*x[i],r,2*i+1,c,x.t-i-1)) >= x.DV) {+ r[i+x.t] -= x.DV;+ r[i+x.t+1] = 1;+ }+ }+ if(r.t > 0) r[r.t-1] += x.am(i,x[i],r,2*i,0,1);+ r.s = 0;+ r.clamp();+}++// (protected) divide this by m, quotient and remainder to q, r (HAC 14.20)+// r != q, this != m. q or r may be null.+function bnpDivRemTo(m,q,r) {+ var pm = m.abs();+ if(pm.t <= 0) return;+ var pt = this.abs();+ if(pt.t < pm.t) {+ if(q != null) q.fromInt(0);+ if(r != null) this.copyTo(r);+ return;+ }+ if(r == null) r = nbi();+ var y = nbi(), ts = this.s, ms = m.s;+ var nsh = this.DB-nbits(pm[pm.t-1]); // normalize modulus+ if(nsh > 0) { pm.lShiftTo(nsh,y); pt.lShiftTo(nsh,r); }+ else { pm.copyTo(y); pt.copyTo(r); }+ var ys = y.t;+ var y0 = y[ys-1];+ if(y0 == 0) return;+ var yt = y0*(1<<this.F1)+((ys>1)?y[ys-2]>>this.F2:0);+ var d1 = this.FV/yt, d2 = (1<<this.F1)/yt, e = 1<<this.F2;+ var i = r.t, j = i-ys, t = (q==null)?nbi():q;+ y.dlShiftTo(j,t);+ if(r.compareTo(t) >= 0) {+ r[r.t++] = 1;+ r.subTo(t,r);+ }+ BigInteger.ONE.dlShiftTo(ys,t);+ t.subTo(y,y); // "negative" y so we can replace sub with am later+ while(y.t < ys) y[y.t++] = 0;+ while(--j >= 0) {+ // Estimate quotient digit+ var qd = (r[--i]==y0)?this.DM:Math.floor(r[i]*d1+(r[i-1]+e)*d2);+ if((r[i]+=y.am(0,qd,r,j,0,ys)) < qd) { // Try it out+ y.dlShiftTo(j,t);+ r.subTo(t,r);+ while(r[i] < --qd) r.subTo(t,r);+ }+ }+ if(q != null) {+ r.drShiftTo(ys,q);+ if(ts != ms) BigInteger.ZERO.subTo(q,q);+ }+ r.t = ys;+ r.clamp();+ if(nsh > 0) r.rShiftTo(nsh,r); // Denormalize remainder+ if(ts < 0) BigInteger.ZERO.subTo(r,r);+}++// (public) this mod a+function bnMod(a) {+ var r = nbi();+ this.abs().divRemTo(a,null,r);+ if(this.s < 0 && r.compareTo(BigInteger.ZERO) > 0) a.subTo(r,r);+ return r;+}++// Modular reduction using "classic" algorithm+function Classic(m) { this.m = m; }+function cConvert(x) {+ if(x.s < 0 || x.compareTo(this.m) >= 0) return x.mod(this.m);+ else return x;+}+function cRevert(x) { return x; }+function cReduce(x) { x.divRemTo(this.m,null,x); }+function cMulTo(x,y,r) { x.multiplyTo(y,r); this.reduce(r); }+function cSqrTo(x,r) { x.squareTo(r); this.reduce(r); }++Classic.prototype.convert = cConvert;+Classic.prototype.revert = cRevert;+Classic.prototype.reduce = cReduce;+Classic.prototype.mulTo = cMulTo;+Classic.prototype.sqrTo = cSqrTo;++// (protected) return "-1/this % 2^DB"; useful for Mont. reduction+// justification:+// xy == 1 (mod m)+// xy = 1+km+// xy(2-xy) = (1+km)(1-km)+// x[y(2-xy)] = 1-k^2m^2+// x[y(2-xy)] == 1 (mod m^2)+// if y is 1/x mod m, then y(2-xy) is 1/x mod m^2+// should reduce x and y(2-xy) by m^2 at each step to keep size bounded.+// JS multiply "overflows" differently from C/C++, so care is needed here.+function bnpInvDigit() {+ if(this.t < 1) return 0;+ var x = this[0];+ if((x&1) == 0) return 0;+ var y = x&3; // y == 1/x mod 2^2+ y = (y*(2-(x&0xf)*y))&0xf; // y == 1/x mod 2^4+ y = (y*(2-(x&0xff)*y))&0xff; // y == 1/x mod 2^8+ y = (y*(2-(((x&0xffff)*y)&0xffff)))&0xffff; // y == 1/x mod 2^16+ // last step - calculate inverse mod DV directly;+ // assumes 16 < DB <= 32 and assumes ability to handle 48-bit ints+ y = (y*(2-x*y%this.DV))%this.DV; // y == 1/x mod 2^dbits+ // we really want the negative inverse, and -DV < y < DV+ return (y>0)?this.DV-y:-y;+}++// Montgomery reduction+function Montgomery(m) {+ this.m = m;+ this.mp = m.invDigit();+ this.mpl = this.mp&0x7fff;+ this.mph = this.mp>>15;+ this.um = (1<<(m.DB-15))-1;+ this.mt2 = 2*m.t;+}++// xR mod m+function montConvert(x) {+ var r = nbi();+ x.abs().dlShiftTo(this.m.t,r);+ r.divRemTo(this.m,null,r);+ if(x.s < 0 && r.compareTo(BigInteger.ZERO) > 0) this.m.subTo(r,r);+ return r;+}++// x/R mod m+function montRevert(x) {+ var r = nbi();+ x.copyTo(r);+ this.reduce(r);+ return r;+}++// x = x/R mod m (HAC 14.32)+function montReduce(x) {+ while(x.t <= this.mt2) // pad x so am has enough room later+ x[x.t++] = 0;+ for(var i = 0; i < this.m.t; ++i) {+ // faster way of calculating u0 = x[i]*mp mod DV+ var j = x[i]&0x7fff;+ var u0 = (j*this.mpl+(((j*this.mph+(x[i]>>15)*this.mpl)&this.um)<<15))&x.DM;+ // use am to combine the multiply-shift-add into one call+ j = i+this.m.t;+ x[j] += this.m.am(0,u0,x,i,0,this.m.t);+ // propagate carry+ while(x[j] >= x.DV) { x[j] -= x.DV; x[++j]++; }+ }+ x.clamp();+ x.drShiftTo(this.m.t,x);+ if(x.compareTo(this.m) >= 0) x.subTo(this.m,x);+}++// r = "x^2/R mod m"; x != r+function montSqrTo(x,r) { x.squareTo(r); this.reduce(r); }++// r = "xy/R mod m"; x,y != r+function montMulTo(x,y,r) { x.multiplyTo(y,r); this.reduce(r); }++Montgomery.prototype.convert = montConvert;+Montgomery.prototype.revert = montRevert;+Montgomery.prototype.reduce = montReduce;+Montgomery.prototype.mulTo = montMulTo;+Montgomery.prototype.sqrTo = montSqrTo;++// (protected) true iff this is even+function bnpIsEven() { return ((this.t>0)?(this[0]&1):this.s) == 0; }++// (protected) this^e, e < 2^32, doing sqr and mul with "r" (HAC 14.79)+function bnpExp(e,z) {+ if(e > 0xffffffff || e < 1) return BigInteger.ONE;+ var r = nbi(), r2 = nbi(), g = z.convert(this), i = nbits(e)-1;+ g.copyTo(r);+ while(--i >= 0) {+ z.sqrTo(r,r2);+ if((e&(1<<i)) > 0) z.mulTo(r2,g,r);+ else { var t = r; r = r2; r2 = t; }+ }+ return z.revert(r);+}++// (public) this^e % m, 0 <= e < 2^32+function bnModPowInt(e,m) {+ var z;+ if(e < 256 || m.isEven()) z = new Classic(m); else z = new Montgomery(m);+ return this.exp(e,z);+}++// protected+BigInteger.prototype.copyTo = bnpCopyTo;+BigInteger.prototype.fromInt = bnpFromInt;+BigInteger.prototype.fromString = bnpFromString;+BigInteger.prototype.clamp = bnpClamp;+BigInteger.prototype.dlShiftTo = bnpDLShiftTo;+BigInteger.prototype.drShiftTo = bnpDRShiftTo;+BigInteger.prototype.lShiftTo = bnpLShiftTo;+BigInteger.prototype.rShiftTo = bnpRShiftTo;+BigInteger.prototype.subTo = bnpSubTo;+BigInteger.prototype.multiplyTo = bnpMultiplyTo;+BigInteger.prototype.squareTo = bnpSquareTo;+BigInteger.prototype.divRemTo = bnpDivRemTo;+BigInteger.prototype.invDigit = bnpInvDigit;+BigInteger.prototype.isEven = bnpIsEven;+BigInteger.prototype.exp = bnpExp;++// public+BigInteger.prototype.toString = bnToString;+BigInteger.prototype.negate = bnNegate;+BigInteger.prototype.abs = bnAbs;+BigInteger.prototype.compareTo = bnCompareTo;+BigInteger.prototype.bitLength = bnBitLength;+BigInteger.prototype.mod = bnMod;+BigInteger.prototype.modPowInt = bnModPowInt;++// "constants"+BigInteger.ZERO = nbv(0);+BigInteger.ONE = nbv(1);++// Copyright (c) 2005-2009 Tom Wu+// All Rights Reserved.+// See "LICENSE" for details.++// Extended JavaScript BN functions, required for RSA private ops.++// Version 1.1: new BigInteger("0", 10) returns "proper" zero+// Version 1.2: square() API, isProbablePrime fix++// (public)+function bnClone() { var r = nbi(); this.copyTo(r); return r; }++// (public) return value as integer+function bnIntValue() {+ if(this.s < 0) {+ if(this.t == 1) return this[0]-this.DV;+ else if(this.t == 0) return -1;+ }+ else if(this.t == 1) return this[0];+ else if(this.t == 0) return 0;+ // assumes 16 < DB < 32+ return ((this[1]&((1<<(32-this.DB))-1))<<this.DB)|this[0];+}++// (public) return value as byte+function bnByteValue() { return (this.t==0)?this.s:(this[0]<<24)>>24; }++// (public) return value as short (assumes DB>=16)+function bnShortValue() { return (this.t==0)?this.s:(this[0]<<16)>>16; }++// (protected) return x s.t. r^x < DV+function bnpChunkSize(r) { return Math.floor(Math.LN2*this.DB/Math.log(r)); }++// (public) 0 if this == 0, 1 if this > 0+function bnSigNum() {+ if(this.s < 0) return -1;+ else if(this.t <= 0 || (this.t == 1 && this[0] <= 0)) return 0;+ else return 1;+}++// (protected) convert to radix string+function bnpToRadix(b) {+ if(b == null) b = 10;+ if(this.signum() == 0 || b < 2 || b > 36) return "0";+ var cs = this.chunkSize(b);+ var a = Math.pow(b,cs);+ var d = nbv(a), y = nbi(), z = nbi(), r = "";+ this.divRemTo(d,y,z);+ while(y.signum() > 0) {+ r = (a+z.intValue()).toString(b).substr(1) + r;+ y.divRemTo(d,y,z);+ }+ return z.intValue().toString(b) + r;+}++// (protected) convert from radix string+function bnpFromRadix(s,b) {+ this.fromInt(0);+ if(b == null) b = 10;+ var cs = this.chunkSize(b);+ var d = Math.pow(b,cs), mi = false, j = 0, w = 0;+ for(var i = 0; i < s.length; ++i) {+ var x = intAt(s,i);+ if(x < 0) {+ if(s.charAt(i) == "-" && this.signum() == 0) mi = true;+ continue;+ }+ w = b*w+x;+ if(++j >= cs) {+ this.dMultiply(d);+ this.dAddOffset(w,0);+ j = 0;+ w = 0;+ }+ }+ if(j > 0) {+ this.dMultiply(Math.pow(b,j));+ this.dAddOffset(w,0);+ }+ if(mi) BigInteger.ZERO.subTo(this,this);+}++// (protected) alternate constructor+function bnpFromNumber(a,b,c) {+ if("number" == typeof b) {+ // new BigInteger(int,int,RNG)+ if(a < 2) this.fromInt(1);+ else {+ this.fromNumber(a,c);+ if(!this.testBit(a-1)) // force MSB set+ this.bitwiseTo(BigInteger.ONE.shiftLeft(a-1),op_or,this);+ if(this.isEven()) this.dAddOffset(1,0); // force odd+ while(!this.isProbablePrime(b)) {+ this.dAddOffset(2,0);+ if(this.bitLength() > a) this.subTo(BigInteger.ONE.shiftLeft(a-1),this);+ }+ }+ }+ else {+ // new BigInteger(int,RNG)+ var x = new Array(), t = a&7;+ x.length = (a>>3)+1;+ b.nextBytes(x);+ if(t > 0) x[0] &= ((1<<t)-1); else x[0] = 0;+ this.fromString(x,256);+ }+}++// (public) convert to bigendian byte array+function bnToByteArray() {+ var i = this.t, r = new Array();+ r[0] = this.s;+ var p = this.DB-(i*this.DB)%8, d, k = 0;+ if(i-- > 0) {+ if(p < this.DB && (d = this[i]>>p) != (this.s&this.DM)>>p)+ r[k++] = d|(this.s<<(this.DB-p));+ while(i >= 0) {+ if(p < 8) {+ d = (this[i]&((1<<p)-1))<<(8-p);+ d |= this[--i]>>(p+=this.DB-8);+ }+ else {+ d = (this[i]>>(p-=8))&0xff;+ if(p <= 0) { p += this.DB; --i; }+ }+ if((d&0x80) != 0) d |= -256;+ if(k == 0 && (this.s&0x80) != (d&0x80)) ++k;+ if(k > 0 || d != this.s) r[k++] = d;+ }+ }+ return r;+}++function bnEquals(a) { return(this.compareTo(a)==0); }+function bnMin(a) { return(this.compareTo(a)<0)?this:a; }+function bnMax(a) { return(this.compareTo(a)>0)?this:a; }++// (protected) r = this op a (bitwise)+function bnpBitwiseTo(a,op,r) {+ var i, f, m = Math.min(a.t,this.t);+ for(i = 0; i < m; ++i) r[i] = op(this[i],a[i]);+ if(a.t < this.t) {+ f = a.s&this.DM;+ for(i = m; i < this.t; ++i) r[i] = op(this[i],f);+ r.t = this.t;+ }+ else {+ f = this.s&this.DM;+ for(i = m; i < a.t; ++i) r[i] = op(f,a[i]);+ r.t = a.t;+ }+ r.s = op(this.s,a.s);+ r.clamp();+}++// (public) this & a+function op_and(x,y) { return x&y; }+function bnAnd(a) { var r = nbi(); this.bitwiseTo(a,op_and,r); return r; }++// (public) this | a+function op_or(x,y) { return x|y; }+function bnOr(a) { var r = nbi(); this.bitwiseTo(a,op_or,r); return r; }++// (public) this ^ a+function op_xor(x,y) { return x^y; }+function bnXor(a) { var r = nbi(); this.bitwiseTo(a,op_xor,r); return r; }++// (public) this & ~a+function op_andnot(x,y) { return x&~y; }+function bnAndNot(a) { var r = nbi(); this.bitwiseTo(a,op_andnot,r); return r; }++// (public) ~this+function bnNot() {+ var r = nbi();+ for(var i = 0; i < this.t; ++i) r[i] = this.DM&~this[i];+ r.t = this.t;+ r.s = ~this.s;+ return r;+}++// (public) this << n+function bnShiftLeft(n) {+ var r = nbi();+ if(n < 0) this.rShiftTo(-n,r); else this.lShiftTo(n,r);+ return r;+}++// (public) this >> n+function bnShiftRight(n) {+ var r = nbi();+ if(n < 0) this.lShiftTo(-n,r); else this.rShiftTo(n,r);+ return r;+}++// return index of lowest 1-bit in x, x < 2^31+function lbit(x) {+ if(x == 0) return -1;+ var r = 0;+ if((x&0xffff) == 0) { x >>= 16; r += 16; }+ if((x&0xff) == 0) { x >>= 8; r += 8; }+ if((x&0xf) == 0) { x >>= 4; r += 4; }+ if((x&3) == 0) { x >>= 2; r += 2; }+ if((x&1) == 0) ++r;+ return r;+}++// (public) returns index of lowest 1-bit (or -1 if none)+function bnGetLowestSetBit() {+ for(var i = 0; i < this.t; ++i)+ if(this[i] != 0) return i*this.DB+lbit(this[i]);+ if(this.s < 0) return this.t*this.DB;+ return -1;+}++// return number of 1 bits in x+function cbit(x) {+ var r = 0;+ while(x != 0) { x &= x-1; ++r; }+ return r;+}++// (public) return number of set bits+function bnBitCount() {+ var r = 0, x = this.s&this.DM;+ for(var i = 0; i < this.t; ++i) r += cbit(this[i]^x);+ return r;+}++// (public) true iff nth bit is set+function bnTestBit(n) {+ var j = Math.floor(n/this.DB);+ if(j >= this.t) return(this.s!=0);+ return((this[j]&(1<<(n%this.DB)))!=0);+}++// (protected) this op (1<<n)+function bnpChangeBit(n,op) {+ var r = BigInteger.ONE.shiftLeft(n);+ this.bitwiseTo(r,op,r);+ return r;+}++// (public) this | (1<<n)+function bnSetBit(n) { return this.changeBit(n,op_or); }++// (public) this & ~(1<<n)+function bnClearBit(n) { return this.changeBit(n,op_andnot); }++// (public) this ^ (1<<n)+function bnFlipBit(n) { return this.changeBit(n,op_xor); }++// (protected) r = this + a+function bnpAddTo(a,r) {+ var i = 0, c = 0, m = Math.min(a.t,this.t);+ while(i < m) {+ c += this[i]+a[i];+ r[i++] = c&this.DM;+ c >>= this.DB;+ }+ if(a.t < this.t) {+ c += a.s;+ while(i < this.t) {+ c += this[i];+ r[i++] = c&this.DM;+ c >>= this.DB;+ }+ c += this.s;+ }+ else {+ c += this.s;+ while(i < a.t) {+ c += a[i];+ r[i++] = c&this.DM;+ c >>= this.DB;+ }+ c += a.s;+ }+ r.s = (c<0)?-1:0;+ if(c > 0) r[i++] = c;+ else if(c < -1) r[i++] = this.DV+c;+ r.t = i;+ r.clamp();+}++// (public) this + a+function bnAdd(a) { var r = nbi(); this.addTo(a,r); return r; }++// (public) this - a+function bnSubtract(a) { var r = nbi(); this.subTo(a,r); return r; }++// (public) this * a+function bnMultiply(a) { var r = nbi(); this.multiplyTo(a,r); return r; }++// (public) this^2+function bnSquare() { var r = nbi(); this.squareTo(r); return r; }++// (public) this / a+function bnDivide(a) { var r = nbi(); this.divRemTo(a,r,null); return r; }++// (public) this % a+function bnRemainder(a) { var r = nbi(); this.divRemTo(a,null,r); return r; }++// (public) [this/a,this%a]+function bnDivideAndRemainder(a) {+ var q = nbi(), r = nbi();+ this.divRemTo(a,q,r);+ return new Array(q,r);+}++// (protected) this *= n, this >= 0, 1 < n < DV+function bnpDMultiply(n) {+ this[this.t] = this.am(0,n-1,this,0,0,this.t);+ ++this.t;+ this.clamp();+}++// (protected) this += n << w words, this >= 0+function bnpDAddOffset(n,w) {+ if(n == 0) return;+ while(this.t <= w) this[this.t++] = 0;+ this[w] += n;+ while(this[w] >= this.DV) {+ this[w] -= this.DV;+ if(++w >= this.t) this[this.t++] = 0;+ ++this[w];+ }+}++// A "null" reducer+function NullExp() {}+function nNop(x) { return x; }+function nMulTo(x,y,r) { x.multiplyTo(y,r); }+function nSqrTo(x,r) { x.squareTo(r); }++NullExp.prototype.convert = nNop;+NullExp.prototype.revert = nNop;+NullExp.prototype.mulTo = nMulTo;+NullExp.prototype.sqrTo = nSqrTo;++// (public) this^e+function bnPow(e) { return this.exp(e,new NullExp()); }++// (protected) r = lower n words of "this * a", a.t <= n+// "this" should be the larger one if appropriate.+function bnpMultiplyLowerTo(a,n,r) {+ var i = Math.min(this.t+a.t,n);+ r.s = 0; // assumes a,this >= 0+ r.t = i;+ while(i > 0) r[--i] = 0;+ var j;+ for(j = r.t-this.t; i < j; ++i) r[i+this.t] = this.am(0,a[i],r,i,0,this.t);+ for(j = Math.min(a.t,n); i < j; ++i) this.am(0,a[i],r,i,0,n-i);+ r.clamp();+}++// (protected) r = "this * a" without lower n words, n > 0+// "this" should be the larger one if appropriate.+function bnpMultiplyUpperTo(a,n,r) {+ --n;+ var i = r.t = this.t+a.t-n;+ r.s = 0; // assumes a,this >= 0+ while(--i >= 0) r[i] = 0;+ for(i = Math.max(n-this.t,0); i < a.t; ++i)+ r[this.t+i-n] = this.am(n-i,a[i],r,0,0,this.t+i-n);+ r.clamp();+ r.drShiftTo(1,r);+}++// Barrett modular reduction+function Barrett(m) {+ // setup Barrett+ this.r2 = nbi();+ this.q3 = nbi();+ BigInteger.ONE.dlShiftTo(2*m.t,this.r2);+ this.mu = this.r2.divide(m);+ this.m = m;+}++function barrettConvert(x) {+ if(x.s < 0 || x.t > 2*this.m.t) return x.mod(this.m);+ else if(x.compareTo(this.m) < 0) return x;+ else { var r = nbi(); x.copyTo(r); this.reduce(r); return r; }+}++function barrettRevert(x) { return x; }++// x = x mod m (HAC 14.42)+function barrettReduce(x) {+ x.drShiftTo(this.m.t-1,this.r2);+ if(x.t > this.m.t+1) { x.t = this.m.t+1; x.clamp(); }+ this.mu.multiplyUpperTo(this.r2,this.m.t+1,this.q3);+ this.m.multiplyLowerTo(this.q3,this.m.t+1,this.r2);+ while(x.compareTo(this.r2) < 0) x.dAddOffset(1,this.m.t+1);+ x.subTo(this.r2,x);+ while(x.compareTo(this.m) >= 0) x.subTo(this.m,x);+}++// r = x^2 mod m; x != r+function barrettSqrTo(x,r) { x.squareTo(r); this.reduce(r); }++// r = x*y mod m; x,y != r+function barrettMulTo(x,y,r) { x.multiplyTo(y,r); this.reduce(r); }++Barrett.prototype.convert = barrettConvert;+Barrett.prototype.revert = barrettRevert;+Barrett.prototype.reduce = barrettReduce;+Barrett.prototype.mulTo = barrettMulTo;+Barrett.prototype.sqrTo = barrettSqrTo;++// (public) this^e % m (HAC 14.85)+function bnModPow(e,m) {+ var i = e.bitLength(), k, r = nbv(1), z;+ if(i <= 0) return r;+ else if(i < 18) k = 1;+ else if(i < 48) k = 3;+ else if(i < 144) k = 4;+ else if(i < 768) k = 5;+ else k = 6;+ if(i < 8)+ z = new Classic(m);+ else if(m.isEven())+ z = new Barrett(m);+ else+ z = new Montgomery(m);++ // precomputation+ var g = new Array(), n = 3, k1 = k-1, km = (1<<k)-1;+ g[1] = z.convert(this);+ if(k > 1) {+ var g2 = nbi();+ z.sqrTo(g[1],g2);+ while(n <= km) {+ g[n] = nbi();+ z.mulTo(g2,g[n-2],g[n]);+ n += 2;+ }+ }++ var j = e.t-1, w, is1 = true, r2 = nbi(), t;+ i = nbits(e[j])-1;+ while(j >= 0) {+ if(i >= k1) w = (e[j]>>(i-k1))&km;+ else {+ w = (e[j]&((1<<(i+1))-1))<<(k1-i);+ if(j > 0) w |= e[j-1]>>(this.DB+i-k1);+ }++ n = k;+ while((w&1) == 0) { w >>= 1; --n; }+ if((i -= n) < 0) { i += this.DB; --j; }+ if(is1) { // ret == 1, don't bother squaring or multiplying it+ g[w].copyTo(r);+ is1 = false;+ }+ else {+ while(n > 1) { z.sqrTo(r,r2); z.sqrTo(r2,r); n -= 2; }+ if(n > 0) z.sqrTo(r,r2); else { t = r; r = r2; r2 = t; }+ z.mulTo(r2,g[w],r);+ }++ while(j >= 0 && (e[j]&(1<<i)) == 0) {+ z.sqrTo(r,r2); t = r; r = r2; r2 = t;+ if(--i < 0) { i = this.DB-1; --j; }+ }+ }+ return z.revert(r);+}++// (public) gcd(this,a) (HAC 14.54)+function bnGCD(a) {+ var x = (this.s<0)?this.negate():this.clone();+ var y = (a.s<0)?a.negate():a.clone();+ if(x.compareTo(y) < 0) { var t = x; x = y; y = t; }+ var i = x.getLowestSetBit(), g = y.getLowestSetBit();+ if(g < 0) return x;+ if(i < g) g = i;+ if(g > 0) {+ x.rShiftTo(g,x);+ y.rShiftTo(g,y);+ }+ while(x.signum() > 0) {+ if((i = x.getLowestSetBit()) > 0) x.rShiftTo(i,x);+ if((i = y.getLowestSetBit()) > 0) y.rShiftTo(i,y);+ if(x.compareTo(y) >= 0) {+ x.subTo(y,x);+ x.rShiftTo(1,x);+ }+ else {+ y.subTo(x,y);+ y.rShiftTo(1,y);+ }+ }+ if(g > 0) y.lShiftTo(g,y);+ return y;+}++// (protected) this % n, n < 2^26+function bnpModInt(n) {+ if(n <= 0) return 0;+ var d = this.DV%n, r = (this.s<0)?n-1:0;+ if(this.t > 0)+ if(d == 0) r = this[0]%n;+ else for(var i = this.t-1; i >= 0; --i) r = (d*r+this[i])%n;+ return r;+}++// (public) 1/this % m (HAC 14.61)+function bnModInverse(m) {+ var ac = m.isEven();+ if((this.isEven() && ac) || m.signum() == 0) return BigInteger.ZERO;+ var u = m.clone(), v = this.clone();+ var a = nbv(1), b = nbv(0), c = nbv(0), d = nbv(1);+ while(u.signum() != 0) {+ while(u.isEven()) {+ u.rShiftTo(1,u);+ if(ac) {+ if(!a.isEven() || !b.isEven()) { a.addTo(this,a); b.subTo(m,b); }+ a.rShiftTo(1,a);+ }+ else if(!b.isEven()) b.subTo(m,b);+ b.rShiftTo(1,b);+ }+ while(v.isEven()) {+ v.rShiftTo(1,v);+ if(ac) {+ if(!c.isEven() || !d.isEven()) { c.addTo(this,c); d.subTo(m,d); }+ c.rShiftTo(1,c);+ }+ else if(!d.isEven()) d.subTo(m,d);+ d.rShiftTo(1,d);+ }+ if(u.compareTo(v) >= 0) {+ u.subTo(v,u);+ if(ac) a.subTo(c,a);+ b.subTo(d,b);+ }+ else {+ v.subTo(u,v);+ if(ac) c.subTo(a,c);+ d.subTo(b,d);+ }+ }+ if(v.compareTo(BigInteger.ONE) != 0) return BigInteger.ZERO;+ if(d.compareTo(m) >= 0) return d.subtract(m);+ if(d.signum() < 0) d.addTo(m,d); else return d;+ if(d.signum() < 0) return d.add(m); else return d;+}++var lowprimes = [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109,113,127,131,137,139,149,151,157,163,167,173,179,181,191,193,197,199,211,223,227,229,233,239,241,251,257,263,269,271,277,281,283,293,307,311,313,317,331,337,347,349,353,359,367,373,379,383,389,397,401,409,419,421,431,433,439,443,449,457,461,463,467,479,487,491,499,503,509,521,523,541,547,557,563,569,571,577,587,593,599,601,607,613,617,619,631,641,643,647,653,659,661,673,677,683,691,701,709,719,727,733,739,743,751,757,761,769,773,787,797,809,811,821,823,827,829,839,853,857,859,863,877,881,883,887,907,911,919,929,937,941,947,953,967,971,977,983,991,997];+var lplim = (1<<26)/lowprimes[lowprimes.length-1];++// (public) test primality with certainty >= 1-.5^t+function bnIsProbablePrime(t) {+ var i, x = this.abs();+ if(x.t == 1 && x[0] <= lowprimes[lowprimes.length-1]) {+ for(i = 0; i < lowprimes.length; ++i)+ if(x[0] == lowprimes[i]) return true;+ return false;+ }+ if(x.isEven()) return false;+ i = 1;+ while(i < lowprimes.length) {+ var m = lowprimes[i], j = i+1;+ while(j < lowprimes.length && m < lplim) m *= lowprimes[j++];+ m = x.modInt(m);+ while(i < j) if(m%lowprimes[i++] == 0) return false;+ }+ return x.millerRabin(t);+}++// (protected) true if probably prime (HAC 4.24, Miller-Rabin)+function bnpMillerRabin(t) {+ var n1 = this.subtract(BigInteger.ONE);+ var k = n1.getLowestSetBit();+ if(k <= 0) return false;+ var r = n1.shiftRight(k);+ t = (t+1)>>1;+ if(t > lowprimes.length) t = lowprimes.length;+ var a = nbi();+ for(var i = 0; i < t; ++i) {+ //Pick bases at random, instead of starting at 2+ a.fromInt(lowprimes[Math.floor(Math.random()*lowprimes.length)]);+ var y = a.modPow(r,this);+ if(y.compareTo(BigInteger.ONE) != 0 && y.compareTo(n1) != 0) {+ var j = 1;+ while(j++ < k && y.compareTo(n1) != 0) {+ y = y.modPowInt(2,this);+ if(y.compareTo(BigInteger.ONE) == 0) return false;+ }+ if(y.compareTo(n1) != 0) return false;+ }+ }+ return true;+}++// protected+BigInteger.prototype.chunkSize = bnpChunkSize;+BigInteger.prototype.toRadix = bnpToRadix;+BigInteger.prototype.fromRadix = bnpFromRadix;+BigInteger.prototype.fromNumber = bnpFromNumber;+BigInteger.prototype.bitwiseTo = bnpBitwiseTo;+BigInteger.prototype.changeBit = bnpChangeBit;+BigInteger.prototype.addTo = bnpAddTo;+BigInteger.prototype.dMultiply = bnpDMultiply;+BigInteger.prototype.dAddOffset = bnpDAddOffset;+BigInteger.prototype.multiplyLowerTo = bnpMultiplyLowerTo;+BigInteger.prototype.multiplyUpperTo = bnpMultiplyUpperTo;+BigInteger.prototype.modInt = bnpModInt;+BigInteger.prototype.millerRabin = bnpMillerRabin;++// public+BigInteger.prototype.clone = bnClone;+BigInteger.prototype.intValue = bnIntValue;+BigInteger.prototype.byteValue = bnByteValue;+BigInteger.prototype.shortValue = bnShortValue;+BigInteger.prototype.signum = bnSigNum;+BigInteger.prototype.toByteArray = bnToByteArray;+BigInteger.prototype.equals = bnEquals;+BigInteger.prototype.min = bnMin;+BigInteger.prototype.max = bnMax;+BigInteger.prototype.and = bnAnd;+BigInteger.prototype.or = bnOr;+BigInteger.prototype.xor = bnXor;+BigInteger.prototype.andNot = bnAndNot;+BigInteger.prototype.not = bnNot;+BigInteger.prototype.shiftLeft = bnShiftLeft;+BigInteger.prototype.shiftRight = bnShiftRight;+BigInteger.prototype.getLowestSetBit = bnGetLowestSetBit;+BigInteger.prototype.bitCount = bnBitCount;+BigInteger.prototype.testBit = bnTestBit;+BigInteger.prototype.setBit = bnSetBit;+BigInteger.prototype.clearBit = bnClearBit;+BigInteger.prototype.flipBit = bnFlipBit;+BigInteger.prototype.add = bnAdd;+BigInteger.prototype.subtract = bnSubtract;+BigInteger.prototype.multiply = bnMultiply;+BigInteger.prototype.divide = bnDivide;+BigInteger.prototype.remainder = bnRemainder;+BigInteger.prototype.divideAndRemainder = bnDivideAndRemainder;+BigInteger.prototype.modPow = bnModPow;+BigInteger.prototype.modInverse = bnModInverse;+BigInteger.prototype.pow = bnPow;+BigInteger.prototype.gcd = bnGCD;+BigInteger.prototype.isProbablePrime = bnIsProbablePrime;++// JSBN-specific extension+BigInteger.prototype.square = bnSquare;++// BigInteger interfaces not implemented in jsbn:++// BigInteger(int signum, byte[] magnitude)+// double doubleValue()+// float floatValue()+// int hashCode()+// long longValue()+//+BigInteger.prototype.lesser = function(rhs) {+ return this.compareTo(rhs) < 0+}+BigInteger.prototype.lesserOrEquals = function(rhs) {+ return this.compareTo(rhs) <= 0+}+BigInteger.prototype.greater = function(rhs) {+ return this.compareTo(rhs) > 0+}+BigInteger.prototype.greaterOrEquals = function(rhs) {+ return this.compareTo(rhs) >= 0+}++return function(val) {+ return new BigInteger(val);+}+})();
lib/Data/Bits.idr view
@@ -32,7 +32,7 @@ %assert_total natToBits' : machineTy n -> Nat -> machineTy n natToBits' a Z = a-natToBits' {n=n} a x with n+natToBits' {n=n} a x with (n) -- it seems I have to manually recover the value of n here, instead of being able to reference it natToBits' a (S x') | Z = natToBits' {n=0} (prim__addB8 a (prim__truncInt_B8 1)) x' natToBits' a (S x') | S Z = natToBits' {n=1} (prim__addB16 a (prim__truncInt_B16 1)) x'@@ -40,7 +40,7 @@ natToBits' a (S x') | S (S (S _)) = natToBits' {n=3} (prim__addB64 a (prim__truncInt_B64 1)) x' natToBits : Nat -> machineTy n-natToBits {n=n} x with n+natToBits {n=n} x with (n) | Z = natToBits' {n=0} (prim__truncInt_B8 0) x | S Z = natToBits' {n=1} (prim__truncInt_B16 0) x | S (S Z) = natToBits' {n=2} (prim__truncInt_B32 0) x@@ -106,7 +106,7 @@ shiftLeft (MkBits x) (MkBits y) = MkBits (shiftLeft' x y) shiftRightLogical' : machineTy n -> machineTy n -> machineTy n-shiftRightLogical' {n=n} x c with n+shiftRightLogical' {n=n} x c with (n) | Z = prim__lshrB8 x c | S Z = prim__lshrB16 x c | S (S Z) = prim__lshrB32 x c@@ -129,7 +129,7 @@ shiftRightArithmetic (MkBits x) (MkBits y) = MkBits (shiftRightArithmetic' x y) and' : machineTy n -> machineTy n -> machineTy n-and' {n=n} x y with n+and' {n=n} x y with (n) | Z = prim__andB8 x y | S Z = prim__andB16 x y | S (S Z) = prim__andB32 x y@@ -140,7 +140,7 @@ and {n} (MkBits x) (MkBits y) = MkBits (and' {n=nextBytes n} x y) or' : machineTy n -> machineTy n -> machineTy n-or' {n=n} x y with n+or' {n=n} x y with (n) | Z = prim__orB8 x y | S Z = prim__orB16 x y | S (S Z) = prim__orB32 x y@@ -151,7 +151,7 @@ or {n} (MkBits x) (MkBits y) = MkBits (or' {n=nextBytes n} x y) xor' : machineTy n -> machineTy n -> machineTy n-xor' {n=n} x y with n+xor' {n=n} x y with (n) | Z = prim__xorB8 x y | S Z = prim__xorB16 x y | S (S Z) = prim__xorB32 x y
lib/Decidable/Equality.idr view
@@ -154,3 +154,21 @@ decEq (x :: xs) (y :: ys) | (No p) | (No p') = No (\eq => lemma_x_neq_xs_neq p p' eq) +--------------------------------------------------------------------------------+-- Vect+--------------------------------------------------------------------------------++total+vectInjective1 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> x = y+vectInjective1 {x=x} {y=x} {xs=xs} {ys=xs} refl = refl++total+vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys+vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} refl = refl++instance DecEq a => DecEq (Vect n a) where+ decEq [] [] = Yes refl+ decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)+ decEq (x :: xs) (x :: xs) | (Yes refl, Yes refl) = Yes refl+ decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p))+ decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p))
+ lib/Language/Reflection/Errors.idr view
@@ -0,0 +1,42 @@+module Language.Reflection.Errors++import Language.Reflection++data SourceLocation = FileLoc String Int++data Err = Msg String+ | InternalMsg String+ | CantUnify Bool TT TT Err (List (TTName, TT)) Int+ -- Int is 'score' - how much we did unify+ -- Bool indicates recoverability, True indicates more info may make+ -- unification succeed+ | InfiniteUnify TTName TT (List (TTName, TT))+ | CantConvert TT TT (List (TTName, TT))+ | UnifyScope TTName TTName TT (List (TTName, TT))+ | CantInferType String+ | NonFunctionType TT TT+ | CantIntroduce TT+ | NoSuchVariable TTName+ | NoTypeDecl TTName+ | NotInjective TT TT TT+ | CantResolve TT+ | CantResolveAlts (List String)+ | IncompleteTT TT+ | UniverseError+ | ProgramLineComment+ | Inaccessible TTName+ | NonCollapsiblePostulate TTName+ | AlreadyDefined TTName+ | ProofSearchFail Err+ | NoRewriting TT+ | At SourceLocation Err+ | Elaborating String TTName Err+ | ProviderError String++-- | Error reports are a list of report parts+data ErrorReport = Message String+ | Name TTName+ | Term TT+++-- Error reports become functions in List (String, TT) -> Err -> ErrorReport
lib/Makefile view
@@ -1,16 +1,17 @@+IDRIS := idris -check: .PHONY+build: .PHONY $(IDRIS) --build base.ipkg -recheck: clean check- install: $(IDRIS) --install base.ipkg clean: .PHONY $(IDRIS) --clean base.ipkg +rebuild: clean build+ linecount: .PHONY- wc -l *.idr Network/*.idr Language/*.idr Prelude/*.idr Data/*.idr Control/Monad/*.idr Control/*.idr+ find . -name '*.idr' | xargs wc -l .PHONY:
lib/Prelude.idr view
@@ -16,6 +16,7 @@ import Prelude.Strings import Prelude.Chars import Prelude.Traversable+import Prelude.Bits %access public %default total@@ -47,17 +48,20 @@ show True = "True" show False = "False" +instance Show () where+ show () = "()"+ instance Show Bits8 where- show = prim__toStrB8+ show b = b8ToString b instance Show Bits16 where- show = prim__toStrB16+ show b = b16ToString b instance Show Bits32 where- show = prim__toStrB32+ show b = b32ToString b instance Show Bits64 where- show = prim__toStrB64+ show b = b64ToString b %assert_total viewB8x16 : Bits8x16 -> (Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8)
+ lib/Prelude/Bits.idr view
@@ -0,0 +1,56 @@+module Prelude.Bits++import Prelude.Strings+import Prelude.Vect++%access public+%default total+++private+toHexDigit : Fin 16 -> Char+toHexDigit n = index n hexVect where+ hexVect : Vect 16 Char+ hexVect = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',+ 'A', 'B', 'C', 'D', 'E', 'F']++b8ToString : Bits8 -> String+b8ToString c = pack [c1, c2] where+ %assert_total -- We will only supply numbers that can fit in 4 bits+ toFin16 : Bits8 -> Fin 16+ toFin16 n = if n == 0+ then fZ+ else believe_me (fS (toFin16 (n-1)))+ c1 = toHexDigit upper where+ upper : Fin 16+ upper = toFin16 (prim__lshrB8 c 4)+ c2 = toHexDigit lower where+ lower : Fin 16+ lower = toFin16 (prim__andB8 c 0xf)++b16ToString : Bits16 -> String+b16ToString c = c1 ++ c2 where+ c1 = b8ToString upper where+ upper : Bits8+ upper = prim__truncB16_B8 (prim__lshrB16 c 8)+ c2 = b8ToString lower where+ lower : Bits8+ lower = prim__truncB16_B8 c++b32ToString : Bits32 -> String+b32ToString c = c1 ++ c2 where+ c1 = b16ToString upper where+ upper : Bits16+ upper = prim__truncB32_B16 (prim__lshrB32 c 16)+ c2 = b16ToString lower where+ lower : Bits16+ lower = prim__truncB32_B16 c++b64ToString : Bits64 -> String+b64ToString c = c1 ++ c2 where+ c1 = b32ToString upper where+ upper : Bits32+ upper = prim__truncB64_B32 (prim__lshrB64 c 32)+ c2 = b32ToString lower where+ lower : Bits32+ lower = prim__truncB64_B32 c
lib/Prelude/Chars.idr view
@@ -35,3 +35,9 @@ then (prim__intToChar (prim__charToInt x + 32)) else x +isHexDigit : Char -> Bool+isHexDigit x = elem (toUpper x) hexChars where+ hexChars : List Char+ hexChars = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',+ 'A', 'B', 'C', 'D', 'E', 'F']+
lib/base.ipkg view
@@ -7,7 +7,7 @@ Prelude.List, Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either, Prelude.Vect, Prelude.Strings, Prelude.Chars, Prelude.Heap, Prelude.Complex, Prelude.Functor, Prelude.Foldable,- Prelude.Traversable,+ Prelude.Traversable, Prelude.Bits, Network.Cgi, Debug.Trace,@@ -20,7 +20,7 @@ Providers, - Language.Reflection, Language.Reflection.Utils,+ Language.Reflection, Language.Reflection.Utils, Language.Reflection.Errors, Data.Morphisms, Data.Bits, Data.Mod2,
llvm/Makefile view
@@ -5,7 +5,7 @@ OBJECTS=$(SOURCES:.c=.o) LIB=libidris_rts.a -all: $(SOURCES) $(LIB)+build: $(SOURCES) $(LIB) $(LIB): $(OBJECTS) ar r $@ $(OBJECTS)
llvm/defs.c view
@@ -11,6 +11,10 @@ fputs(str, stdout); } +void putErr(const char *str) {+ fputs(str, stderr);+}+ void mpz_init_set_ull(mpz_t n, unsigned long long ull) { mpz_init_set_ui(n, (unsigned int)(ull >> 32)); /* n = (unsigned int)(ull >> 32) */
rts/Makefile view
@@ -9,7 +9,7 @@ LIBTARGET = libidris_rts.a -check : $(LIBTARGET) $(DYLIBTARGET)+build: $(LIBTARGET) $(DYLIBTARGET) $(LIBTARGET) : $(OBJS) ar r $(LIBTARGET) $(OBJS)
rts/idris_rts.c view
@@ -146,12 +146,21 @@ } VAL MKSTR(VM* vm, char* str) {+ int len;+ if (str == NULL) {+ len = 0;+ } else {+ len = strlen(str)+1;+ } Closure* cl = allocate(vm, sizeof(Closure) + // Type) + sizeof(char*) +- sizeof(char)*strlen(str)+1, 0);+ sizeof(char)*len, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure);-- strcpy(cl -> info.str, str);+ if (str == NULL) {+ cl->info.str = NULL;+ } else {+ strcpy(cl -> info.str, str);+ } return cl; }
src/Core/ProofState.hs view
@@ -176,13 +176,15 @@ unify' ctxt env topx topy = do ps <- get let dont = dontunify ps- (u, fails) <- traceWhen (unifylog ps) ("Trying " ++ show (topx, topy)) $ + (u, fails) <- traceWhen (unifylog ps) + ("Trying " ++ show (topx, topy) +++ " in " ++ show env ++ + "\nHoles: " ++ show (holes ps) ++ "\n") $ lift $ unify ctxt env topx topy dont (holes ps) traceWhen (unifylog ps) ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++- " in " ++ show env ++ - "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails ++ "\nCurrent problems:\n"- ++ qshow (problems ps) ++ "\nHoles: " ++ show (holes ps) ++ "\n"+ "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails + ++ "\nCurrent problems:\n" ++ qshow (problems ps) -- ++ show (pterm ps) ++ "\n----------") $ case fails of@@ -238,33 +240,60 @@ goal :: Hole -> Term -> TC Goal goal h tm = g [] tm where+ g env (Bind n b@(Guess _ _) sc) + | same h n = return $ GD env b + | otherwise + = gb env b `mplus` g ((n, b):env) sc g env (Bind n b sc) | hole b && same h n = return $ GD env b | otherwise - = gb env b `mplus` g ((n, b):env) sc+ = g ((n, b):env) sc `mplus` gb env b g env (App f a) = g env f `mplus` g env a g env t = fail "Can't find hole" - gb env (Let t v) = g env t `mplus` g env v- gb env (Guess t v) = g env t `mplus` g env v+ gb env (Let t v) = g env v `mplus` g env t+ gb env (Guess t v) = g env v `mplus` g env t gb env t = g env (binderTy t) tactic :: Hole -> RunTactic -> StateT TState TC () tactic h f = do ps <- get- tm' <- atH (context ps) [] (pterm ps)+ (tm', _) <- atH (context ps) [] (pterm ps) ps <- get -- might have changed while processing put (ps { pterm = tm' }) where- atH c env binder@(Bind n b sc) - | hole b && same h n = f c env binder+ updated o = do o' <- o+ return (o', True)++ ulift2 c env op a b + = do (b', u) <- atH c env b+ if u then return (op a b', True)+ else do (a', u) <- atH c env a+ return (op a' b', u)++ -- Search the things most likely to contain the binding first!++ atH :: Context -> Env -> Term -> StateT TState TC (Term, Bool)+ atH c env binder@(Bind n b@(Guess t v) sc) + | same h n = updated (f c env binder) | otherwise - = liftM2 (Bind n) (atHb c env b) (atH c ((n, b) : env) sc) - atH c env (App f a) = liftM2 App (atH c env f) (atH c env a)- atH c env t = return t+ = do -- binder first+ (b', u) <- ulift2 c env Guess t v+ if u then return (Bind n b' sc, True)+ else do (sc', u) <- atH c ((n, b) : env) sc+ return (Bind n b' sc', u)+ atH c env binder@(Bind n b sc) + | hole b && same h n = updated (f c env binder)+ | otherwise -- scope first+ = do (sc', u) <- atH c ((n, b) : env) sc+ if u then return (Bind n b sc', True)+ else do (b', u) <- atHb c env b+ return (Bind n b' sc', u)+ atH c env (App f a) = ulift2 c env App f a+ atH c env t = return (t, False) - atHb c env (Let t v) = liftM2 Let (atH c env t) (atH c env v) - atHb c env (Guess t v) = liftM2 Guess (atH c env t) (atH c env v)- atHb c env t = do ty' <- atH c env (binderTy t)- return $ t { binderTy = ty' }+ atHb c env (Let t v) = ulift2 c env Let t v + atHb c env (Guess t v) = ulift2 c env Guess t v+ atHb c env t = do (ty', u) <- atH c env (binderTy t)+ return (t { binderTy = ty' }, u) computeLet :: Context -> Name -> Term -> Term computeLet ctxt n tm = cl [] tm where@@ -453,8 +482,8 @@ -- dontunify = dontunify ps \\ [x], -- unified = (uh, uns ++ [(x, val)]), instances = instances ps \\ [x] })- return $ {- Bind x (Let ty val) sc -} - instantiate val (pToV x sc)+ let tm' = instantiate val (pToV x sc) in+ return tm' | otherwise = lift $ tfail $ IncompleteTerm val solve _ _ h@(Bind x t sc) = do ps <- get@@ -714,9 +743,6 @@ = case holes ps of [] -> fail "Nothing to fill in." (h:_) -> do ps' <- execStateT (process t h) ps- let pterm' = case solved ps' of- Just s -> updateSolved [s] (pterm ps')- _ -> pterm ps' let (ns', probs') = case solved ps' of Just s -> updateProblems (context ps')@@ -726,7 +752,7 @@ _ -> ([], problems ps') -- rechecking problems may find more solutions, so -- apply them here- let pterm'' = updateSolved ns' pterm'+ let pterm'' = updateSolved ns' (pterm ps') return (ps' { pterm = pterm'', solved = Nothing, problems = probs',
src/Core/TT.hs view
@@ -309,6 +309,9 @@ lookupCtxt :: Name -> Ctxt a -> [a] lookupCtxt n ctxt = map snd (lookupCtxtName n ctxt) +lookupCtxtExact :: Name -> Ctxt a -> [a]+lookupCtxtExact n ctxt = [ v | (nm, v) <- lookupCtxtName n ctxt, nm == n]+ updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a updateDef n f ctxt = let ds = lookupCtxtName n ctxt in
src/Core/Unify.hs view
@@ -34,7 +34,7 @@ match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> TC [(Name, TT Name)] match_unify ctxt env topx topy dont holes =--- trace ("Matching " ++ show (topx, topy)) $+-- trace ("Matching " ++ show (topx, topy)) $ case runStateT (un [] topx topy) (UI 0 []) of OK (v, UI _ []) -> return (filter notTrivial v) res -> @@ -56,6 +56,10 @@ | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] un bnames (P _ x _) (V i) | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return []+ un bnames (Bind x bx sx) (Bind y by sy)+ = do h1 <- uB bnames bx by+ h2 <- un ((x, y) : bnames) sx sy+ combine bnames h1 h2 un names (App fx ax) (App fy ay) = do hf <- un names fx fy ha <- un names ax ay@@ -71,6 +75,19 @@ lift $ tfail err + uB bnames (Let tx vx) (Let ty vy) = do h1 <- un bnames tx ty+ h2 <- un bnames vx vy+ combine bnames h1 h2+ uB bnames (Lam tx) (Lam ty) = un bnames tx ty+ uB bnames (Pi tx) (Pi ty) = un bnames tx ty+ uB bnames x y = do UI s f <- get+ let r = recoverable (binderTy x) (binderTy y)+ let err = CantUnify r topx topy + (CantUnify r (binderTy x) (binderTy y) (Msg "") [] s)+ (errEnv env) s+ put (UI s ((binderTy x, binderTy y, env, err) : f))+ return []+ -- TODO: there's an annoying amount of repetition between this and the -- main unification function. Consider lifting it out. @@ -320,7 +337,8 @@ unArgs vs xs ys metavarApp tm = let (f, args) = unApply tm in- all (\x -> metavar x) (f : args)+ metavar f &&+ all (\x -> metavarApp x) args && nub args == args metavarArgs tm = let (f, args) = unApply tm in all (\x -> metavar x || inenv x) args@@ -391,12 +409,12 @@ uB bnames (Let tx vx) (Let ty vy) = do h1 <- un' False bnames tx ty- h2 <- un' False bnames ty vy+ h2 <- un' False bnames vx vy sc 1 combine bnames h1 h2 uB bnames (Guess tx vx) (Guess ty vy) = do h1 <- un' False bnames tx ty- h2 <- un' False bnames ty vy+ h2 <- un' False bnames vx vy sc 1 combine bnames h1 h2 uB bnames (Lam tx) (Lam ty) = do sc 1; un' False bnames tx ty
src/IRTS/CodegenJavaScript.hs view
@@ -12,6 +12,7 @@ import Util.System import Control.Arrow+import Control.Applicative ((<$>), (<*>), pure) import Data.Char import Data.List import Data.Maybe@@ -37,8 +38,10 @@ data JSNum = JSInt Int | JSFloat Double | JSInteger Integer+ deriving Eq data JS = JSRaw String+ | JSIdent String | JSFunction [String] JS | JSType JSType | JSSeq [JS]@@ -52,6 +55,7 @@ | JSNull | JSThis | JSTrue+ | JSFalse | JSArray [JS] | JSObject [(String, JS)] | JSString String@@ -61,11 +65,15 @@ | JSIndex JS JS | JSCond [(JS, JS)] | JSTernary JS JS JS+ deriving Eq compileJS :: JS -> String compileJS (JSRaw code) = code +compileJS (JSIdent ident) =+ ident+ compileJS (JSFunction args body) = "function(" ++ intercalate "," args@@ -108,6 +116,8 @@ compileJS (JSProj obj field) | JSFunction {} <- obj = concat ["(", compileJS obj, ").", field]+ | JSAssign {} <- obj =+ concat ["(", compileJS obj, ").", field] | otherwise = compileJS obj ++ '.' : field @@ -123,6 +133,9 @@ compileJS JSTrue = "true" +compileJS JSFalse =+ "false"+ compileJS (JSArray elems) = "[" ++ intercalate "," (map compileJS elems) ++ "]" @@ -170,7 +183,7 @@ ] jsCall :: String -> [JS] -> JS-jsCall fun = JSApp (JSRaw fun)+jsCall fun = JSApp (JSIdent fun) jsMeth :: JS -> String -> [JS] -> JS jsMeth obj meth =@@ -186,10 +199,10 @@ jsAnd = JSOp "&&" jsType :: JS-jsType = JSRaw $ idrRTNamespace ++ "Type"+jsType = JSIdent $ idrRTNamespace ++ "Type" jsCon :: JS-jsCon = JSRaw $ idrRTNamespace ++ "Con"+jsCon = JSIdent $ idrRTNamespace ++ "Con" jsTag :: JS -> JS jsTag obj = JSProj obj "tag"@@ -198,8 +211,9 @@ jsTypeTag obj = JSProj obj "type" jsBigInt :: JS -> JS-jsBigInt val =- JSApp (JSRaw $ idrRTNamespace ++ "bigInt") [val]+jsBigInt (JSString "0") = JSIdent "__IDRRT__ZERO"+jsBigInt (JSString "1") = JSIdent "__IDRRT__ONE"+jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val] jsVar :: Int -> String jsVar = ("__var_" ++) . show@@ -212,6 +226,260 @@ ) ) [value] +jsSubst :: String -> JS -> JS -> JS+jsSubst var new (JSVar old)+ | var == translateVariableName old = new++jsSubst var new (JSIdent old)+ | var == old = new++jsSubst var new (JSArray fields) =+ JSArray (map (jsSubst var new) fields)++jsSubst var new (JSNew con [tag, vals]) =+ JSNew con [tag, jsSubst var new vals]++jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) =+ JSNew con [JSFunction [] (+ JSReturn $ JSApp fun (map (jsSubst var new) vars)+ )]++jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (+ JSReturn (JSApp fun args)+ )]) =+ JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (+ JSReturn $ JSApp fun (map (jsSubst var new) args)+ )]++jsSubst var new (JSApp (JSFunction [arg] body) vals)+ | var /= arg =+ JSApp (JSFunction [arg] (+ jsSubst var new body+ )) $ map (jsSubst var new) vals++jsSubst var new (JSReturn ret) =+ JSReturn $ jsSubst var new ret++jsSubst _ _ js = js++inlineJS :: JS -> JS+inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =+ JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []++inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])+ | JSNew con [tag, vals] <- ret+ , opt <- inlineJS val =+ JSNew con [tag, jsSubst arg opt vals]++ | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret+ , opt <- inlineJS val =+ JSNew con [JSFunction [] (+ JSReturn $ JSApp fun (map (jsSubst arg opt) vars)+ )]++ | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (+ JSReturn (JSApp fun args)+ )] <- ret+ , opt <- inlineJS val =+ JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (+ JSReturn $ JSApp fun (map (jsSubst arg opt) args)+ )]++ | JSIndex (JSProj obj field) idx <- ret+ , opt <- inlineJS val =+ JSIndex (JSProj (+ jsSubst arg opt obj+ ) field+ ) (jsSubst arg opt idx)++ | JSOp op lhs rhs <- ret =+ JSOp op (jsSubst arg (inlineJS val) lhs) $+ (jsSubst arg (inlineJS val) rhs)++inlineJS (JSApp fun args) =+ JSApp (inlineJS fun) (map inlineJS args)++inlineJS (JSNew con args) =+ JSNew con $ map inlineJS args++inlineJS (JSArray fields) =+ JSArray (map inlineJS fields)++inlineJS (JSAssign lhs rhs) =+ JSAssign lhs (inlineJS rhs)++inlineJS (JSSeq seq) =+ JSSeq (map inlineJS seq)++inlineJS (JSFunction args body) =+ JSFunction args (inlineJS body)++inlineJS (JSProj (JSFunction args body) "apply") =+ JSProj (JSFunction args (inlineJS body)) "apply"++inlineJS (JSReturn js) =+ JSReturn $ inlineJS js++inlineJS (JSAlloc name (Just js)) =+ JSAlloc name (Just $ inlineJS js)++inlineJS (JSCond cases) =+ JSCond (map (second inlineJS) cases)++inlineJS (JSObject fields) =+ JSObject (map (second inlineJS) fields)++inlineJS js = js++reduceJS :: [JS] -> [JS]+reduceJS js = reduceLoop [] ([], js)++funName :: JS -> String+funName (JSAlloc fun _) = fun++removeIDs :: [JS] -> [JS]+removeIDs js =+ case partition isID js of+ ([], rest) -> rest+ (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest+ where isID :: JS -> Bool+ isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))+ | JSReturn (JSVar _) <- last body = True++ isID _ = False++ idFor :: JS -> (String, Int)+ idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))+ | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)++ removeIDCall :: [(String, Int)] -> JS -> JS+ removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (+ JSReturn (JSApp (JSIdent fun) args)+ )])+ | Just pos <- lookup fun ids+ , pos < length args = args !! pos++ removeIDCall ids (JSNew _ [JSFunction [] (+ JSReturn (JSApp (JSIdent fun) args)+ )])+ | Just pos <- lookup fun ids+ , pos < length args = args !! pos++ removeIDCall ids js@(JSApp id@(JSIdent fun) args)+ | Just pos <- lookup fun ids+ , pos < length args = args !! pos++ removeIDCall ids (JSAlloc fun (Just body)) =+ JSAlloc fun (Just $ removeIDCall ids body)++ removeIDCall ids (JSReturn js) =+ JSReturn $ removeIDCall ids js++ removeIDCall ids (JSSeq js) =+ JSSeq $ map (removeIDCall ids) js++ removeIDCall ids (JSNew con args) =+ JSNew con $ map (removeIDCall ids) args++ removeIDCall ids (JSFunction args body) =+ JSFunction args $ removeIDCall ids body++ removeIDCall ids (JSApp fun args) =+ JSApp (removeIDCall ids fun) $ map (removeIDCall ids) args++ removeIDCall ids (JSProj obj field) =+ JSProj (removeIDCall ids obj) field++ removeIDCall ids (JSCond conds) =+ JSCond $ map (removeIDCall ids *** removeIDCall ids) conds++ removeIDCall ids (JSAssign lhs rhs) =+ JSAssign (removeIDCall ids lhs) (removeIDCall ids rhs)++ removeIDCall ids (JSArray fields) =+ JSArray $ map (removeIDCall ids) fields++ removeIDCall _ js = js+++reduceLoop :: [String] -> ([JS], [JS]) -> [JS]+reduceLoop reduced (cons, program) =+ case partition findConstructors program of+ ([], js) -> cons ++ js+ (candidates, rest) ->+ let names = reduced ++ map funName candidates in+ reduceLoop names (+ cons ++ map reduce candidates, map (reduceCall names) rest+ )+ where findConstructors :: JS -> Bool+ findConstructors js+ | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =+ reducable $ last body+ | otherwise = False+ where reducable :: JS -> Bool+ reducable (JSReturn js) = reducable js+ reducable (JSNew _ args) = and $ map reducable args+ reducable (JSArray fields) = and $ map reducable fields+ reducable (JSNum _) = True+ reducable JSNull = True+ reducable (JSIdent _) = True+ reducable _ = False++ reduce :: JS -> JS+ reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))+ | JSReturn js <- last body = (JSAlloc fun (Just js))++ reduce js = js++ reduceCall :: [String] -> JS -> JS+ reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (+ JSReturn (JSApp id@(JSIdent ret) _)+ )])+ | ret `elem` funs = id++ reduceCall funs js@(JSApp id@(JSIdent fun) _)+ | fun `elem` funs = id++ reduceCall funs (JSAlloc fun (Just body)) =+ JSAlloc fun (Just $ reduceCall funs body)++ reduceCall funs (JSReturn js) =+ JSReturn $ reduceCall funs js++ reduceCall funs (JSSeq js) =+ JSSeq $ map (reduceCall funs) js++ reduceCall funs (JSNew con args) =+ JSNew con $ map (reduceCall funs) args++ reduceCall funs (JSFunction args body) =+ JSFunction args $ reduceCall funs body++ reduceCall funs (JSApp fun args) =+ JSApp (reduceCall funs fun) $ map (reduceCall funs) args++ reduceCall funs (JSProj obj field) =+ JSProj (reduceCall funs obj) field++ reduceCall funs (JSCond conds) =+ JSCond $ map (reduceCall funs *** reduceCall funs) conds++ reduceCall funs (JSAssign lhs rhs) =+ JSAssign (reduceCall funs lhs) (reduceCall funs rhs)++ reduceCall funs (JSArray fields) =+ JSArray $ map (reduceCall funs) fields++ reduceCall _ js = js++optimizeJS :: JS -> JS+optimizeJS = inlineLoop+ where inlineLoop :: JS -> JS+ inlineLoop js+ | opt <- inlineJS js+ , opt /= js = inlineLoop opt+ | otherwise = js+ codegenJavaScript :: JSTarget -> [(Name, SDecl)]@@ -224,13 +492,16 @@ ("#!/usr/bin/env node\n", "-node") JavaScript -> ("", "-browser")- path <- getDataDir- idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"- tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]- writeFile filename $ intercalate "\n" $ [ header- , idrRuntime- , tgtRuntime- ] ++ functions ++ [mainLoop]+ path <- (++) <$> getDataDir <*> (pure "/jsrts/")+ idrRuntime <- readFile $ path ++ "Runtime-common.js"+ tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]+ jsbn <- readFile $ path ++ "jsbn/jsbn.js"+ writeFile filename $ header ++ (+ intercalate "\n" $ [ jsbn+ , idrRuntime+ , tgtRuntime+ ] ++ functions ++ [mainLoop, invokeLoop]+ ) setPermissions filename (emptyPermissions { readable = True , executable = target == Node@@ -241,19 +512,30 @@ def = map (first translateNamespace) definitions functions :: [String]- functions = map (compileJS . translateDeclaration) def+ functions =+ map compileJS ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def) mainLoop :: String mainLoop = compileJS $- JSSeq [ JSAlloc "main" $ Just $ JSFunction [] (- jsTailcall $ jsCall mainFun []- )- , jsCall "main" []- ]+ JSAlloc "main" $ Just $ JSFunction [] (+ case target of+ Node -> mainFun+ JavaScript -> jsMeth (JSIdent "window") "addEventListener" [+ JSString "DOMContentLoaded", JSFunction [] (+ mainFun+ ), JSFalse+ ]+ )+ where+ mainFun :: JS+ mainFun = jsTailcall $ jsCall runMain [] - mainFun :: String- mainFun = idrNamespace ++ translateName (MN 0 "runMain")+ runMain :: String+ runMain = idrNamespace ++ translateName (MN 0 "runMain") + invokeLoop :: String+ invokeLoop = compileJS $ jsCall "main" []+ translateIdentifier :: String -> String translateIdentifier = replaceReserved . concatMap replaceBadChars@@ -351,7 +633,7 @@ translateConstant (AType (ATInt ITChar)) = JSType JSCharTy translateConstant PtrType = JSType JSPtrTy translateConstant Forgot = JSType JSForgotTy-translateConstant (BI i) = jsBigInt $ JSNum (JSInteger i)+translateConstant (BI i) = jsBigInt $ JSString (show i) translateConstant c = JSError $ "Unimplemented Constant: " ++ show c @@ -364,13 +646,13 @@ lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in JSSeq [ lookupTable [(var, "chk")] var cases , jsDecl $ JSFunction ["fn0", "arg0"] (- JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")+ JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0") , JSReturn $ jsLet (translateVariableName var) ( translateExpression val ) (JSTernary ( (JSVar var `jsInstanceOf` jsCon) `jsAnd` (hasProp lookupTableName (translateVariableName var))- ) (JSRaw $+ ) (JSIdent $ lookupTableName ++ lookup ) JSNull )@@ -383,9 +665,9 @@ JSSeq [ lookupTable [] var cases , jsDecl $ JSFunction ["arg0"] (JSReturn $ JSTernary (- (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`+ (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd` (hasProp lookupTableName "arg0")- ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")+ ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSIdent "arg0") ) ] | otherwise =@@ -395,14 +677,14 @@ where hasProp :: String -> String -> JS hasProp table var =- jsMeth (JSRaw table) "hasOwnProperty" [JSRaw $ var ++ ".tag"]+ JSIndex (JSIdent table) (JSProj (JSIdent var) "tag") caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS caseFun aux var cse = jsFunAux aux (translateCase (Just (translateVariableName var)) cse) - getTag :: SAlt -> Maybe String- getTag (SConCase _ tag _ _ _) = Just $ show tag+ getTag :: SAlt -> Maybe Int+ getTag (SConCase _ tag _ _ _) = Just tag getTag _ = Nothing lookupTableName :: String@@ -411,10 +693,22 @@ lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS lookupTable aux var cases = JSAlloc lookupTableName $ Just (- JSObject $ catMaybes $ map (lookupEntry aux var) cases+ JSApp (JSFunction [] (+ JSSeq $ [+ JSAlloc "t" $ Just (JSArray [])+ ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [+ JSReturn (JSIdent "t")+ ]+ )) [] ) where- lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (String, JS)+ assignEntries :: [(Int, JS)] -> [JS]+ assignEntries entries =+ map (\(tag, fun) ->+ JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun+ ) entries++ lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS) lookupEntry aux var alt = do tag <- getTag alt return (tag, caseFun aux var alt)@@ -441,11 +735,11 @@ allocVar n = JSAlloc (jsVar n) Nothing assignVar :: Int -> String -> JS- assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)+ assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s) assignAux :: (LVar, String) -> JS assignAux (var, val) =- JSAssign (JSRaw $ translateVariableName var) (JSRaw val)+ JSAssign (JSIdent $ translateVariableName var) (JSIdent val) p :: [String] p = map translateName params@@ -470,7 +764,7 @@ | False <- tc = jsTailcall $ translateFunctionCall name vars | True <- tc =- JSNew (idrRTNamespace ++ "Tailcall") [JSFunction [] (+ JSNew (idrRTNamespace ++ "Cont") [JSFunction [] ( JSReturn $ translateFunctionCall name vars )] where@@ -480,13 +774,13 @@ translateExpression (SOp op vars) | LNoOp <- op = JSVar (last vars) - | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)+ | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)] | (LPlus (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs] | (LMinus (ATInt ITBig)) <- op- , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]+ , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs] | (LTimes (ATInt ITBig)) <- op- , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]+ , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs] | (LSDiv (ATInt ITBig)) <- op , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs] | (LSRem (ATInt ITBig)) <- op@@ -568,9 +862,9 @@ | (LIntStr ITNative) <- op , (arg:_) <- vars = jsCall "String" [JSVar arg] | (LSExt ITNative ITBig) <- op- , (arg:_) <- vars = jsBigInt $ JSVar arg+ , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg] | (LTrunc ITBig ITNative) <- op- , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []+ , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" [] | (LIntStr ITBig) <- op , (arg:_) <- vars = jsMeth (JSVar arg) "toString" [] | (LStrInt ITBig) <- op@@ -614,7 +908,7 @@ | LStrCons <- op , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs | LStrHead <- op- , (arg:_) <- vars = JSIndex (JSVar arg) (JSRaw "0")+ , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0)) | LStrRev <- op , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')" | LStrIndex <- op@@ -661,17 +955,17 @@ expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch) expandCase var (CaseCond caseTy, branch) | ConCase tag <- caseTy =- let checkCon = JSRaw var `jsInstanceOf` jsCon- checkTag = (JSRaw $ show tag) `jsEq` jsTag (JSRaw var) in+ let checkCon = JSIdent var `jsInstanceOf` jsCon+ checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in (checkCon `jsAnd` checkTag, branch) | TypeCase ty <- caseTy =- let checkTy = JSRaw var `jsInstanceOf` jsType- checkTag = jsTypeTag (JSRaw var) `jsEq` JSType ty in+ let checkTy = JSIdent var `jsInstanceOf` jsType+ checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in (checkTy `jsAnd` checkTag, branch) translateExpression (SCon i name vars) =- JSNew (idrRTNamespace ++ "Con") [ JSRaw $ show i+ JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i , JSArray $ map JSVar vars ] @@ -679,7 +973,7 @@ JSAssign (JSVar var) (translateExpression e) translateExpression (SProj var i) =- JSIndex (JSProj (JSVar var) "vars") (JSRaw $ show i)+ JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i) translateExpression SNothing = JSNull @@ -742,11 +1036,11 @@ matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse) translateCaseCond var cse@(SConstCase cst@(BI _) _) =- let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in+ let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in (RawCond cond, translateCase Nothing cse) translateCaseCond var cse@(SConstCase cst _) =- let cond = JSRaw var `jsEq` translateConstant cst in+ let cond = JSIdent var `jsEq` translateConstant cst in (RawCond cond, translateCase Nothing cse) translateCaseCond var cse@(SConCase _ tag _ _ _) =@@ -758,5 +1052,5 @@ translateCase (Just var) (SConCase a _ _ vars e) = let params = map jsVar [a .. (a + length vars)] in jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [- JSThis, JSProj (JSRaw var) "vars"+ JSThis, JSProj (JSIdent var) "vars" ]
src/IRTS/CodegenLLVM.hs view
@@ -20,7 +20,7 @@ ) import LLVM.General.AST.DataLayout import qualified LLVM.General.PassManager as PM-import qualified LLVM.General.Module as M+import qualified LLVM.General.Module as MO import qualified LLVM.General.AST.IntegerPredicate as IPred import qualified LLVM.General.AST.Linkage as L import qualified LLVM.General.AST.Visibility as V@@ -36,9 +36,9 @@ import Data.List import Data.Maybe import Data.Word-import Data.Set (Set)-import qualified Data.Set as S+import Data.Map (Map) import qualified Data.Map as M+import qualified Data.Set as S import qualified Data.Vector.Unboxed as V import Control.Applicative import Control.Monad.RWS@@ -70,7 +70,7 @@ withTargetMachine target triple cpu S.empty options R.Default CM.Default CGO.Default $ \tm -> do layout <- getTargetMachineDataLayout tm let ast = codegen (Target triple layout) (map snd defs)- result <- runErrorT . M.withModuleFromAST context ast $ \m ->+ result <- runErrorT . MO.withModuleFromAST context ast $ \m -> do let opts = PM.defaultCuratedPassSetSpec { PM.optLevel = Just optimize , PM.simplifyLibCalls = Just True@@ -85,9 +85,9 @@ failInIO :: ErrorT String IO a -> IO a failInIO = either fail return <=< runErrorT -outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()-outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m-outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m+outputModule :: TargetMachine -> FilePath -> OutputType -> MO.Module -> IO ()+outputModule _ file Raw m = failInIO $ MO.writeBitcodeToFile file m+outputModule tm file Object m = failInIO $ MO.writeObjectToFile tm file m outputModule tm file Executable m = withTmpFile $ \obj -> do outputModule tm obj Object m cc <- getCC@@ -193,6 +193,7 @@ , exfun "__idris_gmpFree" VoidType [ptrI8, intPtr] False , exfun "__idris_strRev" ptrI8 [ptrI8] False , exfun "strtoll" (IntegerType 64) [ptrI8, PointerType ptrI8 (AddrSpace 0), IntegerType 32] False+ , exfun "putErr" VoidType [ptrI8] False , exVar (stdinName tgt) ptrI8 , exVar (stdoutName tgt) ptrI8 , exVar (stderrName tgt) ptrI8@@ -244,7 +245,7 @@ codegen :: Target -> [SDecl] -> Module codegen tgt defs = Module "idris" (Just . dataLayout $ tgt) (Just . triple $ tgt) (initDefs tgt ++ globals ++ gendefs) where- (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0+ (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt initialMGS valueType :: Type valueType = NamedTypeReference (Name "valTy")@@ -264,24 +265,34 @@ , ArrayType nargs (PointerType valueType (AddrSpace 0)) ] -type Modgen = RWS Target [Definition] Word+data MGS = MGS { mgsNextGlobalName :: Word+ , mgsForeignSyms :: Map String (FType, [FType])+ } +type Modgen = RWS Target [Definition] MGS++initialMGS :: MGS+initialMGS = MGS { mgsNextGlobalName = 0+ , mgsForeignSyms = M.empty+ }+ cgDef :: SDecl -> Modgen Definition cgDef (SFun name argNames _ expr) = do- nextGlobal <- get+ nextGlobal <- gets mgsNextGlobalName+ existingForeignSyms <- gets mgsForeignSyms tgt <- ask- let (_, CGS { nextGlobalName = nextGlobal' }, (allocas, bbs, globals)) =+ let (_, CGS { nextGlobalName = nextGlobal', foreignSyms = foreignSyms' }, (allocas, bbs, globals)) = runRWS (do r <- cgExpr expr case r of Nothing -> terminate $ Unreachable [] Just r' -> terminate $ Ret (Just r') []) (CGR tgt (show name))- (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) S.empty)+ (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) existingForeignSyms) entryTerm = case bbs of [] -> Do $ Ret Nothing [] BasicBlock n _ _:_ -> Do $ Br n [] tell globals- put nextGlobal'+ put (MGS { mgsNextGlobalName = nextGlobal', mgsForeignSyms = foreignSyms' }) return . GlobalDefinition $ functionDefaults { G.linkage = L.Internal , G.callingConvention = CC.Fast@@ -306,7 +317,7 @@ , currentBlockName :: Name , instAccum :: [Named Instruction] , lexenv :: Env- , foreignSyms :: Set String+ , foreignSyms :: Map String (FType, [FType]) } data CGR = CGR { target :: Target@@ -524,10 +535,10 @@ Just ops -> Just <$> cgOp fn ops Nothing -> return Nothing cgExpr SNothing = return . Just . ConstantOperand $ nullValue-cgExpr (SError msg) = do -- TODO: Print message+cgExpr (SError msg) = do str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8)) (cgConst' (TT.Str (msg ++ "\n")))- inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0+ inst' $ simpleCall "putErr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0 , C.Int 32 0]] inst' Call { isTailCall = True , callingConvention = CC.C@@ -799,9 +810,11 @@ ensureCDecl :: String -> FType -> [FType] -> Codegen Operand ensureCDecl name rty argtys = do syms <- gets foreignSyms- unless (S.member name syms) $- do addGlobal (ffunDecl name rty argtys)- modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) }+ case M.lookup name syms of+ Nothing -> do addGlobal (ffunDecl name rty argtys)+ modify $ \s -> s { foreignSyms = M.insert name (rty, argtys) (foreignSyms s) }+ Just (rty', argtys') -> unless (rty == rty' && argtys == argtys') . fail $+ "Mismatched type declarations for foreign symbol \"" ++ name ++ "\": " ++ show (rty, argtys) ++ " vs " ++ show (rty', argtys') return $ ConstantOperand (C.GlobalReference (Name name)) ffunDecl :: String -> FType -> [FType] -> Global
src/IRTS/Simplified.hs view
@@ -46,7 +46,7 @@ simplify tl (DV (Loc i)) = return (SV (Loc i)) simplify tl (DV (Glob x)) = do ctxt <- ldefs- case lookupCtxt x ctxt of+ case lookupCtxtExact x ctxt of [DConstructor _ t 0] -> return $ SCon t x [] _ -> return $ SV (Glob x) simplify tl (DApp tc n args) = do args' <- mapM sVar args@@ -88,7 +88,7 @@ sVar (DV (Glob x)) = do ctxt <- ldefs- case lookupCtxt x ctxt of+ case lookupCtxtExact x ctxt of [DConstructor _ t 0] -> sVar (DC t x []) _ -> return (Glob x, Nothing) sVar (DV x) = return (x, Nothing)@@ -136,7 +136,7 @@ sc env (SV (Glob n)) = case lookup n (reverse env) of -- most recent first Just i -> do lvar i; return (SV (Loc i))- Nothing -> case lookupCtxt n ctxt of+ Nothing -> case lookupCtxtExact n ctxt of [DConstructor _ i ar] -> if True -- ar == 0 then return (SCon i n [])@@ -146,7 +146,7 @@ [] -> fail $ "Codegen error: No such variable " ++ show n sc env (SApp tc f args) = do args' <- mapM (scVar env) args- case lookupCtxt f ctxt of+ case lookupCtxtExact f ctxt of [DConstructor n tag ar] -> if True -- (ar == length args) then return $ SCon tag n args'@@ -160,7 +160,7 @@ return $ SForeign l ty f args' sc env (SCon tag f args) = do args' <- mapM (scVar env) args- case lookupCtxt f ctxt of+ case lookupCtxtExact f ctxt of [DConstructor n tag ar] -> if True -- (ar == length args) then return $ SCon tag n args'@@ -197,7 +197,7 @@ scVar env (Glob n) = case lookup n (reverse env) of -- most recent first Just i -> do lvar i; return (Loc i)- Nothing -> case lookupCtxt n ctxt of+ Nothing -> case lookupCtxtExact n ctxt of [DConstructor _ i ar] -> fail $ "Codegen error : can't pass constructor here" [_] -> return (Glob n)@@ -207,7 +207,7 @@ scalt env (SConCase _ i n args e) = do let env' = env ++ zip args [length env..]- tag <- case lookupCtxt n ctxt of+ tag <- case lookupCtxtExact n ctxt of [DConstructor _ i ar] -> if True -- (length args == ar) then return i
src/Idris/AbsSyntax.hs view
@@ -76,7 +76,14 @@ addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i } addLangExt :: LanguageExt -> Idris ()-addLangExt TypeProviders = do i <- getIState ; putIState $ i { idris_language_extensions = [TypeProviders] }+addLangExt TypeProviders = do i <- getIState+ putIState $ i {+ idris_language_extensions = TypeProviders : idris_language_extensions i+ }+addLangExt ErrorReflection = do i <- getIState+ putIState $ i {+ idris_language_extensions = ErrorReflection : idris_language_extensions i+ } addTrans :: (Term, Term) -> Idris () addTrans t = do i <- getIState @@ -571,7 +578,7 @@ PPi expl (MN 0 "a") (PRef bi (MN 0 "A")) (PRef bi inferTy)), bi)] -infTerm t = PApp bi (PRef bi inferCon) [pimp (MN 0 "A") Placeholder, pexp t]+infTerm t = PApp bi (PRef bi inferCon) [pimp (MN 0 "A") Placeholder True, pexp t] infP = P (TCon 6 0) inferTy (TType (UVal 0)) getInferTerm, getInferType :: Term -> Term@@ -614,8 +621,8 @@ PType) [("", eqCon, PPi impl (n "a") PType ( PPi impl (n "x") (PRef bi (n "a"))- (PApp bi (PRef bi eqTy) [pimp (n "a") Placeholder,- pimp (n "b") Placeholder,+ (PApp bi (PRef bi eqTy) [pimp (n "a") Placeholder False,+ pimp (n "b") Placeholder False, pexp (PRef bi (n "x")), pexp (PRef bi (n "x"))])), bi)] where n a = MN 0 a@@ -677,6 +684,7 @@ en (PAlternative a as) = PAlternative a (map en as) en (PHidden t) = PHidden (en t) en (PUnifyLog t) = PUnifyLog (en t)+ en (PNoImplicits t) = PNoImplicits (en t) en (PDoBlock ds) = PDoBlock (map (fmap en) ds) en (PProof ts) = PProof (map (fmap en) ts) en (PTactics ts) = PTactics (map (fmap en) ts)@@ -945,7 +953,7 @@ imps top env (PPi (Imp l _ doc) n ty sc) = do let isn = nub (namesIn uvars ist ty) `dropAll` [n] (decls , ns) <- get- put (PImp (getPriority ist ty) l n ty doc : decls, + put (PImp (getPriority ist ty) True l n ty doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc imps top env (PPi (Exp l _ doc) n ty sc) @@ -1004,6 +1012,7 @@ imps False (n:env) sc imps top env (PHidden tm) = imps False env tm imps top env (PUnifyLog tm) = imps False env tm+ imps top env (PNoImplicits tm) = imps False env tm imps top env _ = return () pibind using [] sc = sc@@ -1093,6 +1102,7 @@ ai env (PTactics ts) = PTactics (map (fmap (ai env)) ts) ai env (PRefl fc tm) = PRefl fc (ai env tm) ai env (PUnifyLog tm) = PUnifyLog (ai env tm)+ ai env (PNoImplicits tm) = PNoImplicits (ai env tm) ai env tm = tm handleErr (Left err) = PElabError err@@ -1142,10 +1152,10 @@ PConstraint p l tm d : insertImpl ps given insertImpl (PConstraint p l ty d : ps) given = PConstraint p l (PResolveTC fc) d : insertImpl ps given- insertImpl (PImp p l n ty d : ps) given =+ insertImpl (PImp p _ l n ty d : ps) given = case find n given [] of- Just (tm, given') -> PImp p l n tm "" : insertImpl ps given'- Nothing -> PImp p l n Placeholder "" : insertImpl ps given+ Just (tm, given') -> PImp p False l n tm "" : insertImpl ps given'+ Nothing -> PImp p True l n Placeholder "" : insertImpl ps given insertImpl (PTacImplicit p l n sc ty d : ps) given = case find n given [] of Just (tm, given') -> PTacImplicit p l n sc tm "" : insertImpl ps given'@@ -1156,7 +1166,7 @@ insertImpl _ given = given find n [] acc = Nothing- find n (PImp _ _ n' t _ : gs) acc + find n (PImp _ _ _ n' t _ : gs) acc | n == n' = Just (t, reverse acc ++ gs) find n (PTacImplicit _ _ n' _ t _ : gs) acc | n == n' = Just (t, reverse acc ++ gs)@@ -1186,8 +1196,8 @@ sl (PApp fc fn args) = do fn' <- sl fn args' <- mapM slA args return $ PApp fc fn' args'- where slA (PImp p l n t d) = do t' <- sl t- return $ PImp p l n t' d+ where slA (PImp p m l n t d) = do t' <- sl t+ return $ PImp p m l n t' d slA (PExp p l t d) = do t' <- sl t return $ PExp p l t' d slA (PConstraint p l t d) @@ -1357,6 +1367,8 @@ match (PHidden x) (PHidden y) = match' x y match (PUnifyLog x) y = match' x y match x (PUnifyLog y) = match' x y+ match (PNoImplicits x) y = match' x y+ match x (PNoImplicits y) = match' x y match Placeholder _ = return [] match _ Placeholder = return [] match (PResolveTC _) _ = return []@@ -1404,6 +1416,7 @@ sm xs (PAlternative a as) = PAlternative a (map (sm xs) as) sm xs (PHidden x) = PHidden (sm xs x) sm xs (PUnifyLog x) = PUnifyLog (sm xs x)+ sm xs (PNoImplicits x) = PNoImplicits (sm xs x) sm xs x = x fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs))@@ -1424,6 +1437,7 @@ sm (PAlternative a as) = PAlternative a (map sm as) sm (PHidden x) = PHidden (sm x) sm (PUnifyLog x) = PUnifyLog (sm x)+ sm (PNoImplicits x) = PNoImplicits (sm x) sm x = x
src/Idris/AbsSyntaxTree.hs view
@@ -67,7 +67,7 @@ , opt_cmdline = [] } -data LanguageExt = TypeProviders deriving (Show, Eq, Read, Ord)+data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord) -- | The output mode in use data OutputMode = RawOutput | IdeSlave Integer deriving Show@@ -225,6 +225,7 @@ | LogLvl Int | Spec PTerm | HNF PTerm+ | TestInline PTerm | Defn Name | Info Name | Missing Name@@ -557,6 +558,7 @@ | PImpossible -- ^ Special case for declaring when an LHS can't typecheck | PCoerced PTerm -- ^ To mark a coerced argument, so as not to coerce twice | PUnifyLog PTerm -- ^ dump a trace of unifications when building term+ | PNoImplicits PTerm -- ^ never run implicit converions on the term deriving Eq {-! deriving instance Binary PTerm @@ -581,6 +583,7 @@ mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts) mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts) mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)+ mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm) mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc) mpt x = x @@ -656,6 +659,7 @@ -- TODO: priority no longer serves any purpose, drop it! data PArg' t = PImp { priority :: Int, + machine_inf :: Bool, -- true if the machine inferred it lazyarg :: Bool, pname :: Name, getTm :: t, pargdoc :: String } | PExp { priority :: Int,@@ -672,7 +676,7 @@ deriving (Show, Eq, Functor) instance Sized a => Sized (PArg' a) where- size (PImp p l nm trm _) = 1 + size nm + size trm+ size (PImp p _ l nm trm _) = 1 + size nm + size trm size (PExp p l trm _) = 1 + size trm size (PConstraint p l trm _) = 1 + size trm size (PTacImplicit p l nm scr trm _) = 1 + size nm + size scr + size trm@@ -681,9 +685,9 @@ deriving instance Binary PArg' !-} -pimp n t = PImp 0 True n t ""-pexp t = PExp 0 False t ""-pconst t = PConstraint 0 False t ""+pimp n t mach = PImp 1 mach True n t ""+pexp t = PExp 1 False t ""+pconst t = PConstraint 1 False t "" ptacimp n s t = PTacImplicit 0 True n s t "" type PArg = PArg' PTerm@@ -848,7 +852,7 @@ getImps :: [PArg] -> [(Name, PTerm)] getImps [] = []-getImps (PImp _ _ n tm _ : xs) = (n, tm) : getImps xs+getImps (PImp _ _ _ n tm _ : xs) = (n, tm) : getImps xs getImps (_ : xs) = getImps xs getExps :: [PArg] -> [PTerm]@@ -1040,7 +1044,7 @@ prettySe p _ = text "test" - prettyArgS (PImp _ _ n tm _) = prettyArgSi (n, tm)+ prettyArgS (PImp _ _ _ n tm _) = prettyArgSi (n, tm) prettyArgS (PExp _ _ tm _) = prettyArgSe tm prettyArgS (PConstraint _ _ tm _) = prettyArgSc tm prettyArgS (PTacImplicit _ _ n _ tm _) = prettyArgSti (n, tm)@@ -1177,6 +1181,7 @@ se p bnd (PElabError s) = show s se p bnd (PCoerced t) = se p bnd t se p bnd (PUnifyLog t) = "%unifyLog " ++ se p bnd t+ se p bnd (PNoImplicits t) = "%noimplicit " ++ se p bnd t -- se p bnd x = "Not implemented" slist' p bnd (PApp _ (PRef _ nil) _)@@ -1210,7 +1215,7 @@ natns = "Prelude.Nat." - sArg bnd (PImp _ _ n tm _) = siArg bnd (n, tm)+ sArg bnd (PImp _ _ _ n tm _) = siArg bnd (n, tm) sArg bnd (PExp _ _ tm _) = seArg bnd tm sArg bnd (PConstraint _ _ tm _) = scArg bnd tm sArg bnd (PTacImplicit _ _ n _ tm _) = stiArg bnd (n, tm)@@ -1244,6 +1249,7 @@ size (PAlternative a alts) = 1 + size alts size (PHidden hidden) = size hidden size (PUnifyLog tm) = size tm+ size (PNoImplicits tm) = size tm size PType = 1 size (PConstant const) = 1 + size const size Placeholder = 1@@ -1279,6 +1285,7 @@ ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r ni env (PAlternative a ls) = concatMap (ni env) ls ni env (PUnifyLog tm) = ni env tm+ ni env (PNoImplicits tm) = ni env tm ni env _ = [] -- Return names which are free in the given term.@@ -1304,6 +1311,7 @@ ni env (PAlternative a as) = concatMap (ni env) as ni env (PHidden tm) = ni env tm ni env (PUnifyLog tm) = ni env tm+ ni env (PNoImplicits tm) = ni env tm ni env _ = [] -- Return which of the given names are used in the given term.@@ -1329,4 +1337,6 @@ ni env (PAlternative a as) = concatMap (ni env) as ni env (PHidden tm) = ni env tm ni env (PUnifyLog tm) = ni env tm+ ni env (PNoImplicits tm) = ni env tm ni env _ = []+
src/Idris/Colours.hs view
@@ -13,11 +13,12 @@ , vivid :: Bool , underline :: Bool , bold :: Bool+ , italic :: Bool } deriving (Eq, Show) mkColour :: Color -> IdrisColour-mkColour c = IdrisColour c True False False+mkColour c = IdrisColour c True False False False data ColourTheme = ColourTheme { keywordColour :: IdrisColour , boundVarColour :: IdrisColour@@ -30,21 +31,22 @@ deriving (Eq, Show) defaultTheme :: ColourTheme-defaultTheme = ColourTheme { keywordColour = IdrisColour Black True True True+defaultTheme = ColourTheme { keywordColour = IdrisColour Black True True True False , boundVarColour = mkColour Magenta- , implicitColour = IdrisColour Magenta True True False+ , implicitColour = IdrisColour Magenta True True False False , functionColour = mkColour Green , typeColour = mkColour Blue , dataColour = mkColour Red- , promptColour = IdrisColour Black True False True+ , promptColour = IdrisColour Black True False True False } -- Set the colour of a string using POSIX escape codes colourise :: IdrisColour -> String -> String-colourise (IdrisColour c v u b) str = setSGRCode sgr ++ str ++ setSGRCode [Reset]+colourise (IdrisColour c v u b i) str = setSGRCode sgr ++ str ++ setSGRCode [Reset] where sgr = [SetColor Foreground (if v then Vivid else Dull) c] ++ (if u then [SetUnderlining SingleUnderline] else []) ++- (if b then [SetConsoleIntensity BoldIntensity] else [])+ (if b then [SetConsoleIntensity BoldIntensity] else []) +++ (if i then [SetItalicized True] else []) colouriseKwd :: ColourTheme -> String -> String colouriseKwd t = colourise (keywordColour t)
src/Idris/Completion.hs view
@@ -134,7 +134,7 @@ isCmd ":color" = True isCmd _ = False colours = map (map toLower . show) $ enumFromTo (minBound::Color) maxBound- formats = ["vivid", "dull", "underline", "nounderline", "bold", "nobold"]+ formats = ["vivid", "dull", "underline", "nounderline", "bold", "nobold", "italic", "noitalic"] completeColourFormat = let getCmpl = completeWith (colours ++ formats) in completeWord Nothing " \t" (return . getCmpl)
src/Idris/Coverage.hs view
@@ -60,7 +60,8 @@ _ -> repeat (pexp Placeholder) let tryclauses = mkClauses parg all_args logLvl 2 $ show (length tryclauses) ++ " initially to check"- let new = filter (noMatch i) (mnub i tryclauses)+ logLvl 5 $ showSep "\n" (map (showImp Nothing True False) tryclauses)+ let new = filter (noMatch i) (nub tryclauses) logLvl 1 $ show (length new) ++ " clauses to check for impossibility" logLvl 5 $ "New clauses: \n" ++ showSep "\n" (map (showImp Nothing True False) new) -- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses) @@ -73,18 +74,6 @@ lhsApp (PClause _ _ l _ _ _) = l lhsApp (PWith _ _ l _ _ _) = l - mnub i [] = []- mnub i (x : xs) = - let xs' = filter (\t -> case matchClause i x t of- Right _ -> False- Left _ -> True) xs in- x : mnub i xs'---- if (any (\t -> case matchClause i x t of--- Right _ -> True--- Left _ -> False) xs) then mnub i xs --- else x : mnub i xs- noMatch i tm = all (\x -> case matchClause i (delab' i x True) tm of Right _ -> False Left miss -> True) xs @@ -117,7 +106,7 @@ | length as == length as' = quickEq t t' && and (zipWith quickEq (map getTm as) (map getTm as')) quickEq Placeholder Placeholder = True-quickEq _ _ = False+quickEq x y = False qelem x [] = False qelem x (y : ys) | x `quickEq` y = True@@ -177,20 +166,20 @@ otherPats o@(PApp _ (PRef fc n) xs) = ops fc n xs o otherPats o@(PPair fc l r) = ops fc pairCon- ([pimp (UN "A") Placeholder, pimp (UN "B") Placeholder] +++ ([pimp (UN "A") Placeholder True, + pimp (UN "B") Placeholder True] ++ [pexp l, pexp r]) o otherPats o@(PDPair fc t _ v) = ops fc (UN "Ex_intro") - ([pimp (UN "a") Placeholder, pimp (UN "P") Placeholder] +++ ([pimp (UN "a") Placeholder True, + pimp (UN "P") Placeholder True] ++ [pexp t,pexp v]) o otherPats o@(PConstant c) = return o otherPats arg = return Placeholder - ops fc n xs_in o+ ops fc n xs o | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef n (tt_ctxt i)- = do let force = getForceable i n -- no need to generate forceable positions- let xs = dropForce force xs_in 0 - xs' <- mapM otherPats (map getTm xs)+ = do xs' <- mapM otherPats (map getExpTm xs) let p = resugar (PApp fc (PRef fc n) (zipWith upd xs' xs)) let tyn = getTy n (tt_ctxt i) case lookupCtxt tyn (idris_datatypes i) of@@ -198,6 +187,9 @@ _ -> [p] ops fc n arg o = return Placeholder + getExpTm (PImp _ True _ _ _ _) = Placeholder -- machine inferred, no point!+ getExpTm t = getTm t+ -- put it back to its original form resugar (PApp _ (PRef fc (UN "Ex_intro")) [_,_,t,v]) = PDPair fc (getTm t) Placeholder (getTm v)@@ -346,7 +338,6 @@ -- if it's not total, it can't reduce, to keep -- typechecking decidable case t' of--- FIXME: Put this back when we can handle mutually recursive things p@(Partial _) -> do setAccessibility n Frozen addIBC (IBCAccess n Frozen)
src/Idris/DSL.hs view
@@ -37,6 +37,8 @@ (expandDo dsl r) expandDo dsl (PAlternative a as) = PAlternative a (map (expandDo dsl) as) expandDo dsl (PHidden t) = PHidden (expandDo dsl t)+expandDo dsl (PNoImplicits t) = PNoImplicits (expandDo dsl t)+expandDo dsl (PUnifyLog t) = PUnifyLog (expandDo dsl t) expandDo dsl (PReturn fc) = dsl_return dsl expandDo dsl (PRewrite fc r t ty) = PRewrite fc r (expandDo dsl t) ty@@ -90,6 +92,7 @@ v' i (PHidden t) = PHidden (v' i t) v' i (PIdiom f t) = PIdiom f (v' i t) v' i (PDoBlock ds) = PDoBlock (map (fmap (v' i)) ds)+ v' i (PNoImplicits t) = PNoImplicits (v' i t) v' i t = t mkVar fc 0 = case index_first dsl of
src/Idris/Delaborate.hs view
@@ -11,7 +11,7 @@ import Debug.Trace -bugaddr = "https://github.com/edwinb/Idris-dev/issues"+bugaddr = "https://github.com/idris-lang/Idris-dev/issues" delab :: IState -> Term -> PTerm delab i tm = delab' i tm False@@ -42,7 +42,7 @@ | otherwise = PRef un (dens n) de env _ (Bind n (Lam ty) sc) = PLam n (de env [] ty) (de ((n,n):env) [] sc)- de env (PImp _ _ _ _ _:is) (Bind n (Pi ty) sc) + de env (PImp _ _ _ _ _ _:is) (Bind n (Pi ty) sc) = PPi impl n (de env [] ty) (de ((n,n):env) is sc) de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc) = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)@@ -88,7 +88,7 @@ = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args) | otherwise = PApp un (PRef un n) (map pexp args) - imp (PImp p l n _ d) arg = PImp p l n arg d+ imp (PImp p m l n _ d) arg = PImp p m l n arg d imp (PExp p l _ d) arg = PExp p l arg d imp (PConstraint p l _ d) arg = PConstraint p l arg d imp (PTacImplicit p l n sc _ d) arg = PTacImplicit p l n sc arg d
src/Idris/Docs.hs view
@@ -41,7 +41,7 @@ = Just $ "Class constraint " ++ show (getTm arg) ++ showDoc (pargdoc arg) ++ "\n"- showArg (n, arg@(PImp _ _ _ _ doc))+ showArg (n, arg@(PImp _ _ _ _ _ doc)) | not (null doc) = Just $ "(implicit) " ++ show n ++ " : " ++ show (getTm arg)
src/Idris/ElabDecls.hs view
@@ -414,7 +414,7 @@ = getImplB k sc getImplB k _ = k - renameBs (PImp _ _ _ _ _ : ps) (PPi p n ty s)+ renameBs (PImp _ _ _ _ _ _ : ps) (PPi p n ty s) = PPi p (mkImp n) ty (renameBs ps (substMatch n (PRef fc (mkImp n)) s)) renameBs (_:ps) (PPi p n ty s) = PPi p n ty (renameBs ps s) renameBs _ t = t@@ -932,11 +932,11 @@ propagateParams :: [Name] -> PTerm -> PTerm propagateParams ps (PApp _ (PRef fc n) args) = PApp fc (PRef fc n) (map addP args)- where addP imp@(PImp _ _ _ Placeholder _)+ where addP imp@(PImp _ _ _ _ Placeholder _) | pname imp `elem` ps = imp { getTm = PRef fc (pname imp) } addP t = t propagateParams ps (PRef fc n)- = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x)) ps)+ = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps) propagateParams ps x = x elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock) @@ -1010,6 +1010,8 @@ wb <- mapM (mkAuxC wname lhs (map fst bargs_pre) (map fst bargs_post)) withblock logLvl 3 ("with block " ++ show wb)+ -- propagate totality assertion to the new definitions+ when (AssertTotal `elem` opts) $ setFlags wname [AssertTotal] mapM_ (elabDecl EAll info) wb -- rhs becomes: fname' ps wval@@ -1342,7 +1344,7 @@ = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc') lamBind i _ sc = sc methArgs i (PPi (Imp _ _ _) n ty sc) - = PImp 0 False n (PRef fc (MN i "meth")) "" : methArgs (i+1) sc+ = PImp 0 True False n (PRef fc (MN i "meth")) "" : methArgs (i+1) sc methArgs i (PPi (Exp _ _ _) n ty sc) = PExp 0 False (PRef fc (MN i "meth")) "" : methArgs (i+1) sc methArgs i (PPi (Constraint _ _ _) n ty sc) @@ -1358,7 +1360,7 @@ = do ps' <- getWParams ps ctxt <- getContext case lookupP n ctxt of- [] -> return (pimp n (PRef fc n) : ps')+ [] -> return (pimp n (PRef fc n) True : ps') _ -> return ps' getWParams (_ : ps) = getWParams ps @@ -1501,6 +1503,9 @@ mapM_ (elabDecl EDefns info) ps -- Do totality checking after entire mutual block i <- get+ mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n+ updateContext (simplifyCasedef n))+ (map snd (idris_totcheck i)) mapM_ buildSCG (idris_totcheck i) mapM_ checkDeclTotality (idris_totcheck i) clear_totcheck@@ -1535,9 +1540,12 @@ = do iLOG $ "Elaborating instance " ++ show n elabInstance info s f cs n ps t expn ds elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty)- | what /= EDefns+ | what /= ETypes = do iLOG $ "Elaborating record " ++ show tyn elabRecord info s doc f tyn ty cdoc cn cty+ | otherwise + = do iLOG $ "Elaborating [type of] " ++ show tyn+ elabData info s doc f False (PLaterdecl tyn ty) elabDecl' _ info (PDSL n dsl) = do i <- getIState putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })
src/Idris/ElabTerm.hs view
@@ -97,6 +97,7 @@ elab ist info pattern tcgen fn tm = do let loglvl = opt_logLevel (idris_options ist) when (loglvl > 5) $ unifyLog True+ compute -- expand type synonyms, etc elabE (False, False) tm -- (in argument, guarded) end_unify when pattern -- convert remaining holes to pattern vars@@ -141,6 +142,7 @@ local f = do e <- get_env return (f `elem` map fst e) + elab' ina (PNoImplicits t) = elab' ina t -- skip elabE step elab' ina PType = do apply RType []; solve elab' ina (PConstant c) = do apply (RConstant c) []; solve elab' ina (PQuote r) = do fill r; solve@@ -156,11 +158,13 @@ try (resolveTC 2 fn ist) (do c <- unique_hole (MN 0 "class") instanceArg c)- elab' ina (PRefl fc t) = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder,- pimp (MN 0 "x") t])- elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy) [pimp (MN 0 "a") Placeholder,- pimp (MN 0 "b") Placeholder,- pexp l, pexp r])+ elab' ina (PRefl fc t) + = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder True,+ pimp (MN 0 "x") t False])+ elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy) + [pimp (MN 0 "a") Placeholder True,+ pimp (MN 0 "b") Placeholder False,+ pexp l, pexp r]) elab' ina@(_, a) (PPair fc l r) = do hnf_compute g <- goal@@ -168,8 +172,8 @@ TType _ -> elabE (True, a) (PApp fc (PRef fc pairTy) [pexp l,pexp r]) _ -> elabE (True, a) (PApp fc (PRef fc pairCon)- [pimp (MN 0 "A") Placeholder,- pimp (MN 0 "B") Placeholder,+ [pimp (MN 0 "A") Placeholder True,+ pimp (MN 0 "B") Placeholder True, pexp l, pexp r]) elab' ina (PDPair fc l@(PRef _ n) t r) = case t of @@ -184,12 +188,12 @@ [pexp t, pexp (PLam n Placeholder r)]) asValue = elab' ina (PApp fc (PRef fc existsCon)- [pimp (MN 0 "a") t,- pimp (MN 0 "P") Placeholder,+ [pimp (MN 0 "a") t False,+ pimp (MN 0 "P") Placeholder True, pexp l, pexp r]) elab' ina (PDPair fc l t r) = elab' ina (PApp fc (PRef fc existsCon)- [pimp (MN 0 "a") t,- pimp (MN 0 "P") Placeholder,+ [pimp (MN 0 "a") t False,+ pimp (MN 0 "P") Placeholder True, pexp l, pexp r]) elab' ina (PAlternative True as) = do hnf_compute@@ -493,7 +497,6 @@ (caseBlock fc cname' (reverse args) opts) -- elaborate case env <- get_env- g <- goal updateAux (newdef : ) -- if we haven't got the type yet, hopefully we'll get it later! movelast tyn@@ -556,7 +559,7 @@ elabArgs ina failed fc r (n:ns) ((lazy, t) : args) | lazy && not pattern = do elabArg n (PApp bi (PRef bi (UN "lazy"))- [pimp (UN "a") Placeholder,+ [pimp (UN "a") Placeholder True, pexp t]); | otherwise = elabArg n t where elabArg n t @@ -725,7 +728,7 @@ [] -> [] [args] -> map isImp (snd args) -- won't be overloaded! ps <- get_probs- args <- apply (Var n) imps+ args <- match_apply (Var n) imps ps' <- get_probs when (length ps < length ps') $ fail "Can't apply type class" -- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $@@ -738,7 +741,7 @@ -- if there's any arguments left, we've failed to resolve hs <- get_holes solve- where isImp (PImp p _ _ _ _) = (True, p)+ where isImp (PImp p _ _ _ _ _) = (True, p) isImp arg = (False, priority arg) collectDeferred :: Term -> State [(Name, Type)] Term@@ -807,7 +810,7 @@ show fn')) fnimps tryAll tacs when autoSolve solveAll- where isImp (PImp _ _ _ _ _) = True+ where isImp (PImp _ _ _ _ _ _) = True isImp _ = False envArgs n = do e <- get_env case lookup n e of@@ -1281,6 +1284,12 @@ emptyEnvList :: Raw emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"])) [envTupleType]++-- | Reflect an error into the internal datatype of Idris -- TODO+reflectErr :: Err -> Raw+reflectErr (Msg msg) = raw_apply (Var (NS (UN "Msg") ["Reflection", "Language"])) [reflectConstant (Str msg)]+reflectErr (InternalMsg msg) = raw_apply (Var (NS (UN "InternalMsg") ["Reflection", "Language"])) [reflectConstant (Str msg)]+reflectErr x = trace ("Couldn't reflect error " ++ show x) raw_apply (Var (NS (UN "Msg") ["Reflection", "Language"])) [reflectConstant (Str $ show x)] envTupleType :: Raw envTupleType
src/Idris/IBC.hs view
@@ -23,7 +23,7 @@ import Paths_idris ibcVersion :: Word8-ibcVersion = 39+ibcVersion = 41 data IBCFile = IBCFile { ver :: Word8, sourcefile :: FilePath,@@ -1624,13 +1624,14 @@ instance (Binary t) => Binary (PArg' t) where put x = case x of- PImp x1 x2 x3 x4 x5 -> + PImp x1 x2 x3 x4 x5 x6 -> do putWord8 0 put x1 put x2 put x3 put x4 put x5+ put x6 PExp x1 x2 x3 x4 -> do putWord8 1 put x1@@ -1659,7 +1660,8 @@ x3 <- get x4 <- get x5 <- get- return (PImp x1 x2 x3 x4 x5)+ x6 <- get+ return (PImp x1 x2 x3 x4 x5 x6) 1 -> do x1 <- get x2 <- get x3 <- get
+ src/Idris/ParseData.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}+module Idris.ParseData where++import Prelude hiding (pi)++import Text.Trifecta.Delta+import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)+import Text.Parser.LookAhead+import Text.Parser.Expression+import qualified Text.Parser.Token as Tok+import qualified Text.Parser.Char as Chr+import qualified Text.Parser.Token.Highlight as Hi++import Idris.AbsSyntax+import Idris.ParseHelpers+import Idris.ParseOps+import Idris.ParseExpr+import Idris.DSL++import Core.TT+import Core.Evaluate++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict++import Data.Maybe+import qualified Data.List.Split as Spl+import Data.List+import Data.Monoid+import Data.Char+import qualified Data.HashSet as HS+import qualified Data.Text as T+import qualified Data.ByteString.UTF8 as UTF8++{- |Parses a record type declaration+Record ::=+ DocComment Accessibility? 'record' FnName TypeSig 'where' OpenBlock Constructor KeepTerminator CloseBlock;+-}+record :: SyntaxInfo -> IdrisParser PDecl+record syn = do (doc, acc) <- try (do + doc <- option "" (docComment '|')+ acc <- optional accessibility+ reserved "record"+ return (doc, acc))+ fc <- getFC+ tyn_in <- fnName+ lchar ':'+ ty <- typeExpr (allowImp syn)+ let tyn = expandNS syn tyn_in+ reserved "where"+ (cdoc, cn, cty, _) <- indentedBlockS (constructor syn)+ accData acc tyn [cn]+ let rsyn = syn { syn_namespace = show (nsroot tyn) :+ syn_namespace syn }+ let fns = getRecNames rsyn cty+ mapM_ (\n -> addAcc n acc) fns+ return $ PRecord doc rsyn fc tyn ty cdoc cn cty+ <?> "record type declaration"+ where+ getRecNames :: SyntaxInfo -> PTerm -> [Name]+ getRecNames syn (PPi _ n _ sc) = [expandNS syn n, expandNS syn (mkType n)]+ ++ getRecNames syn sc+ getRecNames _ _ = []++ toFreeze :: Maybe Accessibility -> Maybe Accessibility+ toFreeze (Just Frozen) = Just Hidden+ toFreeze x = x++{- | Parses data declaration type (normal or codata)+DataI ::= 'data' | 'codata';+-}+dataI :: IdrisParser Bool+dataI = do reserved "data"; return False+ <|> do reserved "codata"; return True++{- | Parses a data type declaration+Data ::= DocComment? Accessibility? DataI FnName TypeSig ExplicitTypeDataRest?+ | DocComment? Accessibility? DataI FnName Name* DataRest?+ ;+Constructor' ::= Constructor KeepTerminator;+ExplicitTypeDataRest ::= 'where' OpenBlock Constructor'* CloseBlock;++DataRest ::= '=' SimpleConstructorList Terminator+ | 'where'!+ ;+SimpleConstructorList ::=+ SimpleConstructor+ | SimpleConstructor '|' SimpleConstructorList+ ;+-}+data_ :: SyntaxInfo -> IdrisParser PDecl+data_ syn = do (doc, acc, co) <- try (do+ doc <- option "" (docComment '|')+ pushIndent+ acc <- optional accessibility+ co <- dataI+ return (doc, acc, co))+ fc <- getFC+ tyn_in <- fnName+ (do try (lchar ':')+ popIndent+ ty <- typeExpr (allowImp syn)+ let tyn = expandNS syn tyn_in+ option (PData doc syn fc co (PLaterdecl tyn ty)) (do+ reserved "where"+ cons <- indentedBlock (constructor syn)+ accData acc tyn (map (\ (_, n, _, _) -> n) cons)+ return $ PData doc syn fc co (PDatadecl tyn ty cons))) <|> (do+ args <- many name+ let ty = bindArgs (map (const PType) args) PType+ let tyn = expandNS syn tyn_in+ option (PData doc syn fc co (PLaterdecl tyn ty)) (do+ try (lchar '=') <|> do reserved "where"+ let kw = (if co then "co" else "") ++ "data "+ let n = show tyn_in ++ " "+ let s = kw ++ n+ let as = concat (intersperse " " $ map show args) ++ " "+ let ns = concat (intersperse " -> " $ map ((\x -> "(" ++ x ++ " : Type)") . show) args)+ let ss = concat (intersperse " -> " $ map (const "Type") args)+ let fix1 = s ++ as ++ " = ..."+ let fix2 = s ++ ": " ++ ns ++ " -> Type where\n ..."+ let fix3 = s ++ ": " ++ ss ++ " -> Type where\n ..."+ fail $ fixErrorMsg "unexpected \"where\"" [fix1, fix2, fix3]+ cons <- sepBy1 (simpleConstructor syn) (lchar '|')+ terminator+ let conty = mkPApp fc (PRef fc tyn) (map (PRef fc) args)+ cons' <- mapM (\ (doc, x, cargs, cfc) ->+ do let cty = bindArgs cargs conty+ return (doc, x, cty, cfc)) cons+ accData acc tyn (map (\ (_, n, _, _) -> n) cons')+ return $ PData doc syn fc co (PDatadecl tyn ty cons')))+ <?> "data type declaration"+ where+ mkPApp :: FC -> PTerm -> [PTerm] -> PTerm+ mkPApp fc t [] = t+ mkPApp fc t xs = PApp fc t (map pexp xs)+ bindArgs :: [PTerm] -> PTerm -> PTerm+ bindArgs xs t = foldr (PPi expl (MN 0 "t")) t xs+++{- | Parses a type constructor declaration+ Constructor ::= DocComment? FnName TypeSig;+-}+constructor :: SyntaxInfo -> IdrisParser (String, Name, PTerm, FC)+constructor syn+ = do doc <- option "" (docComment '|')+ cn_in <- fnName; fc <- getFC+ let cn = expandNS syn cn_in+ lchar ':'+ ty <- typeExpr (allowImp syn)+ return (doc, cn, ty, fc)+ <?> "constructor"++{- | Parses a constructor for simple discriminative union data types+ SimpleConstructor ::= FnName SimpleExpr* DocComment?+-}+simpleConstructor :: SyntaxInfo -> IdrisParser (String, Name, [PTerm], FC)+simpleConstructor syn+ = do cn_in <- fnName+ let cn = expandNS syn cn_in+ fc <- getFC+ args <- many (do notEndApp+ simpleExpr syn)+ doc <- option "" (docComment '^')+ return (doc, cn, args, fc)+ <?> "constructor"++{- | Parses a dsl block declaration+DSL ::= 'dsl' FnName OpenBlock Overload'+ CloseBlock;+ -}+dsl :: SyntaxInfo -> IdrisParser PDecl+dsl syn = do reserved "dsl"+ n <- fnName+ bs <- indentedBlock (overload syn)+ let dsl = mkDSL bs (dsl_info syn)+ checkDSL dsl+ i <- get+ put (i { idris_dsls = addDef n dsl (idris_dsls i) })+ return (PDSL n dsl)+ <?> "dsl block declaration"+ where mkDSL :: [(String, PTerm)] -> DSL -> DSL+ mkDSL bs dsl = let var = lookup "variable" bs+ first = lookup "index_first" bs+ next = lookup "index_next" bs+ leto = lookup "let" bs+ lambda = lookup "lambda" bs in+ initDSL { dsl_var = var,+ index_first = first,+ index_next = next,+ dsl_lambda = lambda,+ dsl_let = leto }++{- | Checks DSL for errors -}+-- FIXME: currently does nothing, check if DSL is really sane+checkDSL :: DSL -> IdrisParser ()+checkDSL dsl = return ()++{- | Parses a DSL overload declaration+OverloadIdentifier ::= 'let' | Identifier;+Overload ::= OverloadIdentifier '=' Expr;+-}+overload :: SyntaxInfo -> IdrisParser (String, PTerm)+overload syn = do o <- identifier <|> do reserved "let"+ return "let"+ if o `notElem` overloadable+ then fail $ show o ++ " is not an overloading"+ else do+ lchar '='+ t <- expr syn+ return (o, t)+ <?> "dsl overload declaratioN"+ where overloadable = ["let","lambda","index_first","index_next","variable"]++
+ src/Idris/ParseExpr.hs view
@@ -0,0 +1,1042 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}+module Idris.ParseExpr where++import Prelude hiding (pi)++import Text.Trifecta.Delta+import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)+import Text.Parser.LookAhead+import Text.Parser.Expression+import qualified Text.Parser.Token as Tok+import qualified Text.Parser.Char as Chr+import qualified Text.Parser.Token.Highlight as Hi++import Idris.AbsSyntax+import Idris.ParseHelpers+import Idris.ParseOps+import Idris.DSL++import Core.TT++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict++import Data.Maybe+import qualified Data.List.Split as Spl+import Data.List+import Data.Monoid+import Data.Char+import qualified Data.HashSet as HS+import qualified Data.Text as T+import qualified Data.ByteString.UTF8 as UTF8++-- | Allow implicit type declarations+allowImp :: SyntaxInfo -> SyntaxInfo+allowImp syn = syn { implicitAllowed = True }++-- | Disallow implicit type declarations+disallowImp :: SyntaxInfo -> SyntaxInfo+disallowImp syn = syn { implicitAllowed = False }++{- | Parses an expression as a whole+ FullExpr ::= Expr EOF_t;+ -}+fullExpr :: SyntaxInfo -> IdrisParser PTerm+fullExpr syn = do x <- expr syn+ eof+ i <- get+ return $ desugar syn i x+++{- |Parses an expression+ Expr ::= Expr';+-}+expr :: SyntaxInfo -> IdrisParser PTerm+expr syn = do i <- get+ buildExpressionParser (table (idris_infixes i)) (expr' syn)++{- | Parses either an internally defined expression or+ a user-defined one++Expr' ::= "External (User-defined) Syntax"+ | InternalExpr;++ -}+expr' :: SyntaxInfo -> IdrisParser PTerm+expr' syn = try (externalExpr syn)+ <|> internalExpr syn+ <?> "expression"++{- | Parses a user-defined expression -}+externalExpr :: SyntaxInfo -> IdrisParser PTerm+externalExpr syn = do i <- get+ extensions syn (syntax_rules i)+ <?> "user-defined expression"++{- | Parses a simple user-defined expression -}+simpleExternalExpr :: SyntaxInfo -> IdrisParser PTerm+simpleExternalExpr syn = do i <- get+ extensions syn (filter isSimple (syntax_rules i))+ where+ isSimple (Rule (Expr x:xs) _ _) = False+ isSimple (Rule (SimpleExpr x:xs) _ _) = False+ isSimple (Rule [Keyword _] _ _) = True+ isSimple (Rule [Symbol _] _ _) = True+ isSimple (Rule (_:xs) _ _) = case last xs of+ Keyword _ -> True+ Symbol _ -> True+ _ -> False+ isSimple _ = False++{- | Tries to parse a user-defined expression given a list of syntactic extensions -}+extensions :: SyntaxInfo -> [Syntax] -> IdrisParser PTerm+extensions syn rules = choice (map (try . extension syn) (filter isValid rules))+ <?> "user-defined expression"+ where+ isValid :: Syntax -> Bool+ isValid (Rule _ _ AnySyntax) = True+ isValid (Rule _ _ PatternSyntax) = inPattern syn+ isValid (Rule _ _ TermSyntax) = not (inPattern syn)+++data SynMatch = SynTm PTerm | SynBind Name++{- | Tries to parse an expression given a user-defined rule -}+extension :: SyntaxInfo -> Syntax -> IdrisParser PTerm+extension syn (Rule ssym ptm _)+ = do smap <- mapM extensionSymbol ssym+ let ns = mapMaybe id smap+ return (update ns ptm) -- updated with smap+ where+ extensionSymbol :: SSymbol -> IdrisParser (Maybe (Name, SynMatch))+ extensionSymbol (Keyword n) = do reserved (show n); return Nothing+ extensionSymbol (Expr n) = do tm <- expr syn+ return $ Just (n, SynTm tm)+ extensionSymbol (SimpleExpr n) = do tm <- simpleExpr syn+ return $ Just (n, SynTm tm)+ extensionSymbol (Binding n) = do b <- name+ return $ Just (n, SynBind b)+ extensionSymbol (Symbol s) = do symbol s+ return Nothing+ dropn :: Name -> [(Name, a)] -> [(Name, a)]+ dropn n [] = []+ dropn n ((x,t) : xs) | n == x = xs+ | otherwise = (x,t):dropn n xs++ updateB :: [(Name, SynMatch)] -> Name -> Name+ updateB ns n = case lookup n ns of+ Just (SynBind t) -> t+ _ -> n++ update :: [(Name, SynMatch)] -> PTerm -> PTerm+ update ns (PRef fc n) = case lookup n ns of+ Just (SynTm t) -> t+ _ -> PRef fc n+ update ns (PLam n ty sc) = PLam (updateB ns n) (update ns ty) (update (dropn n ns) sc)+ update ns (PPi p n ty sc) = PPi p (updateB ns n) (update ns ty) (update (dropn n ns) sc)+ update ns (PLet n ty val sc) = PLet (updateB ns n) (update ns ty) (update ns val)+ (update (dropn n ns) sc)+ update ns (PApp fc t args) = PApp fc (update ns t) (map (fmap (update ns)) args)+ update ns (PCase fc c opts) = PCase fc (update ns c) (map (pmap (update ns)) opts)+ update ns (PPair fc l r) = PPair fc (update ns l) (update ns r)+ update ns (PDPair fc l t r) = PDPair fc (update ns l) (update ns t) (update ns r)+ update ns (PAlternative a as) = PAlternative a (map (update ns) as)+ update ns (PHidden t) = PHidden (update ns t)+ update ns (PDoBlock ds) = PDoBlock $ upd ns ds+ where upd :: [(Name, SynMatch)] -> [PDo] -> [PDo]+ upd ns (DoExp fc t : ds) = DoExp fc (update ns t) : upd ns ds+ upd ns (DoBind fc n t : ds) = DoBind fc n (update ns t) : upd (dropn n ns) ds+ upd ns (DoLet fc n ty t : ds) = DoLet fc n (update ns ty) (update ns t)+ : upd (dropn n ns) ds+ upd ns (DoBindP fc i t : ds) = DoBindP fc (update ns i) (update ns t)+ : upd ns ds+ upd ns (DoLetP fc i t : ds) = DoLetP fc (update ns i) (update ns t)+ : upd ns ds+ update ns (PGoal fc r n sc) = PGoal fc (update ns r) n (update ns sc)+ update ns t = t++{- |Parses a (normal) built-in expression++InternalExpr ::=+ App+ | MatchApp+ | UnifyLog+ | RecordType+ | SimpleExpr+ | Lambda+ | QuoteGoal+ | Let+ | RewriteTerm+ | Pi+ | DoBlock+ ;+-}+internalExpr :: SyntaxInfo -> IdrisParser PTerm+internalExpr syn =+ try (app syn)+ <|> try (matchApp syn)+ <|> try (unifyLog syn)+ <|> try (noImplicits syn)+ <|> recordType syn+ <|> lambda syn+ <|> quoteGoal syn+ <|> let_ syn+ <|> rewriteTerm syn+ <|> try(pi syn)+ <|> doBlock syn+ <|> simpleExpr syn+ <?> "expression"++{- | Parses a case expression+CaseExpr ::=+ 'case' Expr 'of' OpenBlock CaseOption+ CloseBlock;+-}+caseExpr :: SyntaxInfo -> IdrisParser PTerm+caseExpr syn = do reserved "case"; fc <- getFC+ scr <- expr syn; reserved "of";+ opts <- indentedBlock1 (caseOption syn)+ return (PCase fc scr opts)+ <?> "case expression"++{- | Parses a case in a case expression+CaseOption ::=+ Expr '=>' Expr Terminator+ ;+-}+caseOption :: SyntaxInfo -> IdrisParser (PTerm, PTerm)+caseOption syn = do lhs <- expr (syn { inPattern = True })+ symbol "=>"; r <- expr syn+ return (lhs, r)+ <?> "case option"++{- | Parses a proof block+ProofExpr ::=+ 'proof' OpenBlock Tactic'* CloseBlock+ ;+-}+proofExpr :: SyntaxInfo -> IdrisParser PTerm+proofExpr syn = do reserved "proof"+ ts <- indentedBlock (tactic syn)+ return $ PProof ts+ <?> "proof block"++{- | Parses a tactics block+TacticsExpr :=+ 'tactics' OpenBlock Tactic'* CloseBlock+;+-}+tacticsExpr :: SyntaxInfo -> IdrisParser PTerm+tacticsExpr syn = do reserved "tactics"+ ts <- indentedBlock (tactic syn)+ return $ PTactics ts+ <?> "tactics block"++{- | Parses a simple expresion+SimpleExpr ::=+ '![' Term ']'+ | '?' Name+ | % 'instance'+ | 'refl' ('{' Expr '}')?+ | ProofExpr+ | TacticsExpr+ | CaseExpr+ | FnName+ | List+ | Comprehension+ | Alt+ | Idiom+ | '(' Bracketed+ | Constant+ | Type+ | '_|_'+ | '_'+ | {- External (User-defined) Simple Expression -}+ ;+-}+simpleExpr :: SyntaxInfo -> IdrisParser PTerm+simpleExpr syn =+ {-try (do symbol "!["; t <- term; lchar ']'; return $ PQuote t)+ <|>-} do lchar '?'; x <- name; return (PMetavar x)+ <|> do lchar '%'; fc <- getFC; reserved "instance"; return (PResolveTC fc)+ <|> do reserved "refl"; fc <- getFC;+ tm <- option Placeholder (do lchar '{'; t <- expr syn; lchar '}';+ return t)+ return (PRefl fc tm)+ <|> proofExpr syn+ <|> tacticsExpr syn+ <|> caseExpr syn+ <|> do reserved "Type"; return PType+ <|> do fc <- getFC+ x <- fnName+ return (PRef fc x)+ <|> try (listExpr syn)+ <|> try (comprehension syn)+ <|> alt syn+ <|> idiom syn+ <|> do lchar '('+ bracketed (disallowImp syn)+ <|> do c <- constant+ fc <- getFC+ return (modifyConst syn fc (PConstant c))+ <|> do symbol "_|_"+ fc <- getFC+ return (PFalse fc)+ <|> do lchar '_'; return Placeholder+ <|> simpleExternalExpr syn+ <?> "expression"+++{- |Parses the rest of an expression in braces+Bracketed ::=+ ')'+ | Expr ')'+ | ExprList ')'+ | Expr '**' Expr ')'+ | Operator Expr ')'+ | Expr Operator ')'+ | Name ':' Expr '**' Expr ')'+ ;+-}+bracketed :: SyntaxInfo -> IdrisParser PTerm+bracketed syn =+ do lchar ')'+ fc <- getFC+ return $ PTrue fc+ <|>+ try (do l <- expr syn+ lchar ')'+ return l) + <|> do (l, fc) <- try (do+ l <- expr syn+ fc <- getFC+ lchar ','+ return (l, fc))+ rs <- sepBy1 (do fc' <- getFC; r <- expr syn; return (r, fc')) (lchar ',')+ lchar ')'+ return $ PPair fc l (mergePairs rs)+ <|> do (l, fc) <- try (do+ l <- expr syn+ fc <- getFC+ reservedOp "**"+ return (l, fc))+ r <- expr syn+ lchar ')'+ return (PDPair fc l Placeholder r)+ <|> try(do fc0 <- getFC+ l <- expr' syn+ o <- operator+ lchar ')'+ return $ PLam (MN 1000 "ARG") Placeholder+ (PApp fc0 (PRef fc0 (UN o)) [pexp l,+ pexp (PRef fc0 (MN 1000 "ARG"))]))+ <|> try(do fc <- getFC; o <- operator; e <- expr syn; lchar ')'+ return $ PLam (MN 1000 "ARG") Placeholder+ (PApp fc (PRef fc (UN o)) [pexp (PRef fc (MN 1000 "ARG")),+ pexp e]))+ <|> try (do ln <- name; lchar ':'+ lty <- expr syn+ reservedOp "**"+ fc <- getFC+ r <- expr syn+ lchar ')'+ return (PDPair fc (PRef fc ln) lty r))+ <?> "end of braced expression"+ where mergePairs :: [(PTerm, FC)] -> PTerm+ mergePairs [(t, fc)] = t+ mergePairs ((t, fc):rs) = PPair fc t (mergePairs rs)++-- bit of a hack here. If the integer doesn't fit in an Int, treat it as a+-- big integer, otherwise try fromInteger and the constants as alternatives.+-- a better solution would be to fix fromInteger to work with Integer, as the+-- name suggests, rather than Int+{-| Finds optimal type for integer constant -}+modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm+modifyConst syn fc (PConstant (BI x))+ | not (inPattern syn)+ = PAlternative False+ (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI (fromInteger x)))]+ : consts)+ | otherwise = PAlternative False consts+ where+ consts = [ PConstant (BI x)+ , PConstant (I (fromInteger x))+ , PConstant (B8 (fromInteger x))+ , PConstant (B16 (fromInteger x))+ , PConstant (B32 (fromInteger x))+ , PConstant (B64 (fromInteger x))+ ]+modifyConst syn fc x = x++{- | Parses a list literal expression e.g. [1,2,3]+ListExpr ::=+ '[' ExprList? ']'+;++ExprList ::=+ Expr+ | Expr ',' ExprList+ ;++ -}+listExpr :: SyntaxInfo -> IdrisParser PTerm+listExpr syn = do lchar '['; fc <- getFC; xs <- sepBy (expr syn) (lchar ','); lchar ']'+ return (mkList fc xs)+ <?> "list expression"+ where+ mkList :: FC -> [PTerm] -> PTerm+ mkList fc [] = PRef fc (UN "Nil")+ mkList fc (x : xs) = PApp fc (PRef fc (UN "::")) [pexp x, pexp (mkList fc xs)]+++{- | Parses an alternative expression+ Alt ::= '(|' Expr_List '|)';++ Expr_List ::=+ Expr'+ | Expr' ',' Expr_List+ ;+-}+alt :: SyntaxInfo -> IdrisParser PTerm+alt syn = do symbol "(|"; alts <- sepBy1 (expr' syn) (lchar ','); symbol "|)"+ return (PAlternative False alts)++{- | Parses a possibly hidden simple expression+HSimpleExpr ::=+ '.' SimpleExpr+ | SimpleExpr+ ;+-}+hsimpleExpr :: SyntaxInfo -> IdrisParser PTerm+hsimpleExpr syn =+ do lchar '.'+ e <- simpleExpr syn+ return $ PHidden e+ <|> simpleExpr syn+ <?> "expression"++{- | Parses a matching application expression+MatchApp ::=+ SimpleExpr '<==' FnName+ ;+-}+matchApp :: SyntaxInfo -> IdrisParser PTerm+matchApp syn = do ty <- simpleExpr syn+ symbol "<=="+ fc <- getFC+ f <- fnName+ return (PLet (MN 0 "match")+ ty+ (PMatchApp fc f)+ (PRef fc (MN 0 "match")))+ <?> "matching application expression"++{- | Parses a unification log expression+UnifyLog ::=+ '%' 'unifyLog' SimpleExpr+ ;+-}+unifyLog :: SyntaxInfo -> IdrisParser PTerm+unifyLog syn = do lchar '%'; reserved "unifyLog";+ tm <- simpleExpr syn+ return (PUnifyLog tm)+ <?> "unification log expression"++{- | Parses a no implicits expression+NoImplicits ::=+ '%' 'noImplicits' SimpleExpr+ ;+-}+noImplicits :: SyntaxInfo -> IdrisParser PTerm+noImplicits syn = do lchar '%'; reserved "noImplicits";+ tm <- simpleExpr syn+ return (PNoImplicits tm)+ <?> "no implicits expression"++{- | Parses a function application expression+App ::=+ 'mkForeign' Arg Arg*+ | SimpleExpr Arg++ ;+-}+app :: SyntaxInfo -> IdrisParser PTerm+app syn = do f <- reserved "mkForeign"+ fc <- getFC+ fn <- arg syn+ args <- many (do notEndApp; arg syn)+ i <- get+ -- mkForeign f args ==>+ -- liftPrimIO (\w => mkForeignPrim f args w)+ let ap = PApp fc (PRef fc (UN "liftPrimIO"))+ [pexp (PLam (MN 0 "w")+ Placeholder+ (PApp fc (PRef fc (UN "mkForeignPrim"))+ (fn : args +++ [pexp (PRef fc (MN 0 "w"))])))]+ return (dslify i ap)++ <|> do f <- simpleExpr syn+ fc <- getFC+ args <- some (do notEndApp; arg syn)+ i <- get+ return (dslify i $ PApp fc f args)+ <?> "function application"+ where+ dslify :: IState -> PTerm -> PTerm+ dslify i (PApp fc (PRef _ f) [a])+ | [d] <- lookupCtxt f (idris_dsls i)+ = desugar (syn { dsl_info = d }) i (getTm a)+ dslify i t = t++{- |Parses a function argument+Arg ::=+ ImplicitArg+ | ConstraintArg+ | SimpleExpr+ ;+-}+arg :: SyntaxInfo -> IdrisParser PArg+arg syn = implicitArg syn+ <|> constraintArg syn+ <|> do e <- simpleExpr syn+ return (pexp e)+ <?> "function argument"++{- |Parses an implicit function argument+ImplicitArg ::=+ '{' Name ('=' Expr)? '}'+ ;+-}+implicitArg :: SyntaxInfo -> IdrisParser PArg+implicitArg syn = do lchar '{'+ n <- name+ fc <- getFC+ v <- option (PRef fc n) (do lchar '='+ expr syn)+ lchar '}'+ return (pimp n v False)+ <?> "implicit function argument"++{- |Parses a constraint argument (for selecting a named type class instance)+ConstraintArg ::=+ '@{' Expr '}'+ ;+-}+constraintArg :: SyntaxInfo -> IdrisParser PArg+constraintArg syn = do symbol "@{"+ e <- expr syn+ symbol "}"+ return (pconst e)+ <?> "constraint argument"+++{- |Parses a record field setter expression+RecordType ::=+ 'record' '{' FieldTypeList '}';++FieldTypeList ::=+ FieldType+ | FieldType ',' FieldTypeList+ ;++FieldType ::=+ FnName '=' Expr+ ;+-}+recordType :: SyntaxInfo -> IdrisParser PTerm+recordType syn+ = do reserved "record"+ lchar '{'+ fields <- sepBy1 fieldType (lchar ',')+ lchar '}'+ fc <- getFC+ rec <- optional (simpleExpr syn)+ case rec of+ Nothing ->+ return (PLam (MN 0 "fldx") Placeholder+ (applyAll fc fields (PRef fc (MN 0 "fldx"))))+ Just v -> return (applyAll fc fields v)+ <?> "record setting expression"+ where fieldType :: IdrisParser (Name, PTerm)+ fieldType = do n <- fnName+ lchar '='+ e <- expr syn+ return (n, e)+ <?> "field setter"+ applyAll :: FC -> [(Name, PTerm)] -> PTerm -> PTerm+ applyAll fc [] x = x+ applyAll fc ((n, e) : es) x+ = applyAll fc es (PApp fc (PRef fc (mkType n)) [pexp e, pexp x])++{- |Creates setters for record types on necessary functions -}+mkType :: Name -> Name+mkType (UN n) = UN ("set_" ++ n)+mkType (MN 0 n) = MN 0 ("set_" ++ n)+mkType (NS n s) = NS (mkType n) s++{- |Parses a type signature+TypeSig ::=+ ':' Expr+ ;+TypeExpr ::= ConstraintList? Expr;+ -}+typeExpr :: SyntaxInfo -> IdrisParser PTerm+typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []+ sc <- expr syn+ return (bindList (PPi constraint) (map (\x -> (MN 0 "c", x)) cs) sc)+ <?> "type signature"++{- |Parses a lambda expression+Lambda ::=+ '\\' TypeOptDeclList '=>' Expr+ | '\\' SimpleExprList '=>' Expr+ ;+SimpleExprList ::=+ SimpleExpr+ | SimpleExpr ',' SimpleExprList+ ;+-}+lambda :: SyntaxInfo -> IdrisParser PTerm+lambda syn = do lchar '\\'+ try (do xt <- tyOptDeclList syn+ symbol "=>"+ sc <- expr syn+ return (bindList PLam xt sc)+ <|> (do ps <- sepBy (do fc <- getFC+ e <- simpleExpr syn+ return (fc, e)) (lchar ',')+ symbol "=>"+ sc <- expr syn+ return (pmList (zip [0..] ps) sc)))+ <?> "lambda expression"+ where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm+ pmList [] sc = sc+ pmList ((i, (fc, x)) : xs) sc+ = PLam (MN i "lamp") Placeholder+ (PCase fc (PRef fc (MN i "lamp"))+ [(x, pmList xs sc)])++{- |Parses a term rewrite expression+RewriteTerm ::=+ 'rewrite' Expr ('==>' Expr)? 'in' Expr+ ;+-}+rewriteTerm :: SyntaxInfo -> IdrisParser PTerm+rewriteTerm syn = do reserved "rewrite"+ fc <- getFC+ prf <- expr syn+ giving <- optional (do symbol "==>"; expr' syn)+ reserved "in"; sc <- expr syn+ return (PRewrite fc+ (PApp fc (PRef fc (UN "sym")) [pexp prf]) sc+ giving)+ <?> "term rewrite expression"++{- |Parses a let binding+Let ::=+ 'let' Name TypeSig'? '=' Expr 'in' Expr+| 'let' Expr' '=' Expr' 'in' Expr++TypeSig' ::=+ ':' Expr'+ ;+ -}+let_ :: SyntaxInfo -> IdrisParser PTerm+let_ syn = try (do reserved "let"; n <- name;+ ty <- option Placeholder (do lchar ':'; expr' syn)+ lchar '='+ v <- expr syn+ reserved "in"; sc <- expr syn+ return (PLet n ty v sc))+ <|> (do reserved "let"; fc <- getFC; pat <- expr' (syn { inPattern = True } )+ symbol "="; v <- expr syn+ reserved "in"; sc <- expr syn+ return (PCase fc v [(pat, sc)]))+ <?> "let binding"++{- |Parses a quote goal+QuoteGoal ::=+ 'quoteGoal' Name 'by' Expr 'in' Expr+ ;+ -}+quoteGoal :: SyntaxInfo -> IdrisParser PTerm+quoteGoal syn = do reserved "quoteGoal"; n <- name;+ reserved "by"+ r <- expr syn+ reserved "in"+ fc <- getFC+ sc <- expr syn+ return (PGoal fc r n sc)+ <?> "quote goal expression"++{- |Parses a dependent type signature+Pi ::=+ '|'? Static? '(' TypeDeclList ')' DocComment '->' Expr+ | '|'? Static? '{' TypeDeclList '}' '->' Expr+ | '{' 'auto' TypeDeclList '}' '->' Expr+ | '{' 'default' TypeDeclList '}' '->' Expr+ | '{' 'static' '}' Expr' '->' Expr+ ;+ -}++pi :: SyntaxInfo -> IdrisParser PTerm+pi syn =+ do lazy <- if implicitAllowed syn -- laziness is top level only+ then option False (do lchar '|'; return True)+ else return False+ st <- static+ (do try(lchar '('); xt <- typeDeclList syn; lchar ')'+ doc <- option "" (docComment '^')+ symbol "->"+ sc <- expr syn+ return (bindList (PPi (Exp lazy st doc)) xt sc)) <|> (do+ lchar '{'+ (do reserved "auto"+ when (lazy || (st == Static)) $ fail "auto type constraints can not be lazy or static"+ xt <- typeDeclList syn+ lchar '}'+ symbol "->"+ sc <- expr syn+ return (bindList (PPi+ (TacImp False Dynamic (PTactics [Trivial]) "")) xt sc)) <|> (do+ reserved "default"+ when (lazy || (st == Static)) $ fail "default tactic constraints can not be lazy or static"+ script <- simpleExpr syn+ xt <- typeDeclList syn+ lchar '}'+ symbol "->"+ sc <- expr syn+ return (bindList (PPi (TacImp False Dynamic script "")) xt sc)) <|> (do+ reserved "static"+ lchar '}'+ t <- expr' syn+ symbol "->"+ sc <- expr syn+ return (PPi (Exp False Static "") (MN 42 "__pi_arg") t sc)) <|> (+ if implicitAllowed syn then do+ xt <- typeDeclList syn+ lchar '}'+ symbol "->"+ sc <- expr syn+ return (bindList (PPi (Imp lazy st "")) xt sc)+ else do fail "no implicit arguments allowed here"))+ <?> "dependent type signature"++{- | Parses a type constraint list+ConstraintList ::=+ '(' Expr_List ')' '=>'+ | Expr '=>'+ ;+-}+constraintList :: SyntaxInfo -> IdrisParser [PTerm]+constraintList syn = try (do lchar '('+ tys <- sepBy1 (expr' (disallowImp syn)) (lchar ',')+ lchar ')'+ reservedOp "=>"+ return tys)+ <|> try (do t <- expr (disallowImp syn)+ reservedOp "=>"+ return [t])+ <|> return []+ <?> "type constraint list"++{- |Parses a type declaration list+TypeDeclList ::=+ FunctionSignatureList+ | NameList TypeSig+ ;++FunctionSignatureList ::=+ Name TypeSig+ | Name TypeSig ',' FunctionSignatureList+ ;+-}+typeDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]+typeDeclList syn = try (sepBy1 (do x <- fnName+ lchar ':'+ t <- typeExpr (disallowImp syn)+ return (x,t))+ (lchar ','))+ <|> do ns <- sepBy1 name (lchar ',')+ lchar ':'+ t <- typeExpr (disallowImp syn)+ return (map (\x -> (x, t)) ns)+ <?> "type declaration list"++{- |Parses a type declaration list with optional parameters+TypeOptDeclList ::=+ NameOrPlaceholder TypeSig?+ | NameOrPlaceholder TypeSig? ',' TypeOptDeclList+ ;++NameOrPlaceHolder ::= Name | '_';+-}+tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]+tyOptDeclList syn = sepBy1 (do x <- nameOrPlaceholder+ t <- option Placeholder (do lchar ':'+ expr syn)+ return (x,t))+ (lchar ',')+ <?> "type declaration list"+ where nameOrPlaceholder :: IdrisParser Name+ nameOrPlaceholder = fnName+ <|> do symbol "_"+ return (MN 0 "underscore")+ <?> "name or placeholder"++{- |Parses a list comprehension+Comprehension ::= '[' Expr '|' DoList ']';++DoList ::=+ Do+ | Do ',' DoList+ ;+-}+comprehension :: SyntaxInfo -> IdrisParser PTerm+comprehension syn+ = do lchar '['+ fc <- getFC+ pat <- expr syn+ lchar '|'+ qs <- sepBy1 (do_ syn) (lchar ',')+ lchar ']'+ return (PDoBlock (map addGuard qs +++ [DoExp fc (PApp fc (PRef fc (UN "return"))+ [pexp pat])]))+ <?> "list comprehension"+ where addGuard :: PDo -> PDo+ addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc (UN "guard"))+ [pexp e])+ addGuard x = x++{- |Parses a do-block+Do' ::= Do KeepTerminator;++DoBlock ::=+ 'do' OpenBlock Do'+ CloseBlock+ ;+ -}+doBlock :: SyntaxInfo -> IdrisParser PTerm+doBlock syn+ = do reserved "do"+ ds <- indentedBlock (do_ syn)+ return (PDoBlock ds)+ <?> "do block"++{- |Parses an expression inside a do block+Do ::=+ 'let' Name TypeSig'? '=' Expr+ | 'let' Expr' '=' Expr+ | Name '<-' Expr+ | Expr' '<-' Expr+ | Expr+ ;+-}+do_ :: SyntaxInfo -> IdrisParser PDo+do_ syn+ = try (do reserved "let"+ i <- name+ ty <- option Placeholder (do lchar ':'+ expr' syn)+ reservedOp "="+ fc <- getFC+ e <- expr syn+ return (DoLet fc i ty e))+ <|> try (do reserved "let"+ i <- expr' syn+ reservedOp "="+ fc <- getFC+ sc <- expr syn+ return (DoLetP fc i sc))+ <|> try (do i <- name+ symbol "<-"+ fc <- getFC+ e <- expr syn;+ return (DoBind fc i e))+ <|> try (do i <- expr' syn+ symbol "<-"+ fc <- getFC+ e <- expr syn;+ return (DoBindP fc i e))+ <|> do e <- expr syn+ fc <- getFC+ return (DoExp fc e)+ <?> "do block expression"++{- |Parses an expression in idiom brackets+Idiom ::= '[|' Expr '|]';+-}+idiom :: SyntaxInfo -> IdrisParser PTerm+idiom syn+ = do symbol "[|"+ fc <- getFC+ e <- expr syn+ symbol "|]"+ return (PIdiom fc e)+ <?> "expression in idiom brackets"++{- |Parses a constant or literal expression+Constant ::=+ 'Integer'+ | 'Int'+ | 'Char'+ | 'Float'+ | 'String'+ | 'Ptr'+ | 'Bits8'+ | 'Bits16'+ | 'Bits32'+ | 'Bits64'+ | 'Bits8x16'+ | 'Bits16x8'+ | 'Bits32x4'+ | 'Bits64x2'+ | Float_t+ | Natural_t+ | String_t+ | Char_t+ ;+-}+constant :: IdrisParser Core.TT.Const+constant = do reserved "Integer";return (AType (ATInt ITBig))+ <|> do reserved "Int"; return (AType (ATInt ITNative))+ <|> do reserved "Char"; return (AType (ATInt ITChar))+ <|> do reserved "Float"; return (AType ATFloat)+ <|> do reserved "String"; return StrType+ <|> do reserved "Ptr"; return PtrType+ <|> do reserved "Bits8"; return (AType (ATInt (ITFixed IT8)))+ <|> do reserved "Bits16"; return (AType (ATInt (ITFixed IT16)))+ <|> do reserved "Bits32"; return (AType (ATInt (ITFixed IT32)))+ <|> do reserved "Bits64"; return (AType (ATInt (ITFixed IT64)))+ <|> do reserved "Bits8x16"; return (AType (ATInt (ITVec IT8 16)))+ <|> do reserved "Bits16x8"; return (AType (ATInt (ITVec IT16 8)))+ <|> do reserved "Bits32x4"; return (AType (ATInt (ITVec IT32 4)))+ <|> do reserved "Bits64x2"; return (AType (ATInt (ITVec IT64 2)))+ <|> try (do f <- float; return $ Fl f)+ <|> try (do i <- natural; return $ BI i)+ <|> try (do s <- stringLiteral; return $ Str s)+ <|> try (do c <- charLiteral; return $ Ch c)+ <?> "constant or literal"++{- |Parses a static modifier+Static ::=+ '[' static ']'+;+-}+static :: IdrisParser Static+static = do lchar '['; reserved "static"; lchar ']'; return Static+ <|> return Dynamic+ <?> "static modifier"++{- | Parses a tactic script+Tactic ::= 'intro' NameList?+ | 'intros'+ | 'refine' Name Imp++ | 'mrefine' Name+ | 'rewrite' Expr+ | 'equiv' Expr+ | 'let' Name ':' Expr' '=' Expr+ | 'let' Name '=' Expr+ | 'focus' Name+ | 'exact' Expr+ | 'applyTactic' Expr+ | 'reflect' Expr+ | 'fill' Expr+ | 'try' Tactic '|' Tactic+ | '{' TacticSeq '}'+ | 'compute'+ | 'trivial'+ | 'solve'+ | 'attack'+ | 'state'+ | 'term'+ | 'undo'+ | 'qed'+ | 'abandon'+ | ':' 'q'+ ;++Imp ::= '?' | '_';++TacticSeq ::=+ Tactic ';' Tactic+ | Tactic ';' TacticSeq+ ;++-}++tactic :: SyntaxInfo -> IdrisParser PTactic+tactic syn = do reserved "intro"; ns <- sepBy name (lchar ',')+ return $ Intro ns+ <|> do reserved "intros"; return Intros+ <|> try (do reserved "refine"; n <- name+ imps <- some imp+ return $ Refine n imps)+ <|> do reserved "refine"; n <- name+ i <- get+ return $ Refine n []+ <|> do reserved "mrefine"; n <- name+ i <- get+ return $ MatchRefine n+ <|> do reserved "rewrite"; t <- expr syn;+ i <- get+ return $ Rewrite (desugar syn i t)+ <|> do reserved "equiv"; t <- expr syn;+ i <- get+ return $ Equiv (desugar syn i t)+ <|> try (do reserved "let"; n <- name; lchar ':';+ ty <- expr' syn; lchar '='; t <- expr syn;+ i <- get+ return $ LetTacTy n (desugar syn i ty) (desugar syn i t))+ <|> try (do reserved "let"; n <- name; lchar '=';+ t <- expr syn;+ i <- get+ return $ LetTac n (desugar syn i t))+ <|> do reserved "focus"; n <- name+ return $ Focus n+ <|> do reserved "exact"; t <- expr syn;+ i <- get+ return $ Exact (desugar syn i t)+ <|> do reserved "applyTactic"; t <- expr syn;+ i <- get+ return $ ApplyTactic (desugar syn i t)+ <|> do reserved "reflect"; t <- expr syn;+ i <- get+ return $ Reflect (desugar syn i t)+ <|> do reserved "fill"; t <- expr syn;+ i <- get+ return $ Fill (desugar syn i t)+ <|> do reserved "try"; t <- tactic syn;+ lchar '|';+ t1 <- tactic syn+ return $ Try t t1+ <|> do lchar '{'+ t <- tactic syn;+ lchar ';';+ ts <- sepBy1 (tactic syn) (lchar ';')+ lchar '}'+ return $ TSeq t (mergeSeq ts)+ <|> do reserved "compute"; return Compute+ <|> do reserved "trivial"; return Trivial+ <|> do reserved "solve"; return Solve+ <|> do reserved "attack"; return Attack+ <|> do reserved "state"; return ProofState+ <|> do reserved "term"; return ProofTerm+ <|> do reserved "undo"; return Undo+ <|> do reserved "qed"; return Qed+ <|> do reserved "abandon"; return Abandon+ <|> do lchar ':'; reserved "q"; return Abandon+ <?> "tactic"+ where+ imp :: IdrisParser Bool+ imp = do lchar '?'; return False+ <|> do lchar '_'; return True+ mergeSeq :: [PTactic] -> PTactic+ mergeSeq [t] = t+ mergeSeq (t:ts) = TSeq t (mergeSeq ts)++{- | Parses a tactic as a whole -}+fullTactic :: SyntaxInfo -> IdrisParser PTactic+fullTactic syn = do t <- tactic syn+ eof+ return t
+ src/Idris/ParseHelpers.hs view
@@ -0,0 +1,461 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}+module Idris.ParseHelpers where++import Prelude hiding (pi)++import Text.Trifecta.Delta+import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)+import Text.Parser.LookAhead+import Text.Parser.Expression+import qualified Text.Parser.Token as Tok+import qualified Text.Parser.Char as Chr+import qualified Text.Parser.Token.Highlight as Hi++import Idris.AbsSyntax++import Core.TT+import Core.Evaluate++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict++import Data.Maybe+import qualified Data.List.Split as Spl+import Data.List+import Data.Monoid+import Data.Char+import qualified Data.HashSet as HS+import qualified Data.Text as T+import qualified Data.ByteString.UTF8 as UTF8++import System.FilePath++-- | Idris parser with state used during parsing+type IdrisParser = StateT IState IdrisInnerParser++newtype IdrisInnerParser a = IdrisInnerParser { runInnerParser :: Parser a }+ deriving (Monad, Functor, MonadPlus, Applicative, Alternative, CharParsing, LookAheadParsing, Parsing, DeltaParsing, MarkParsing Delta, Monoid)++instance TokenParsing IdrisInnerParser where+ someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()++-- | Generalized monadic parsing constraint type+type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m)++{- * Space, comments and literals (token/lexing like parsers) -}++-- | Consumes any simple whitespace (any character which satisfies Char.isSpace)+simpleWhiteSpace :: MonadicParsing m => m ()+simpleWhiteSpace = satisfy isSpace *> pure ()++-- | Checks if a charcter is end of line+isEol :: Char -> Bool+isEol '\n' = True+isEol _ = False++eol :: MonadicParsing m => m ()+eol = (satisfy isEol *> pure ()) <|> lookAhead eof <?> "end of line"++-- | Checks if a character is a documentation comment marker+isDocCommentMarker :: Char -> Bool+isDocCommentMarker '|' = True+isDocCommentMarker '^' = True+isDocCommentMarker _ = False++{- | Consumes a single-line comment+ SingleLineComment_t ::= '--' EOL_t+ | '--' ~DocCommentMarker_t ~EOL_t* EOL_t+ ;+ -}+singleLineComment :: MonadicParsing m => m ()+singleLineComment = try (string "--" *> eol *> pure ())+ <|> string "--" *> satisfy (not . isDocCommentMarker) *> many (satisfy (not . isEol)) *> eol *> pure ()+ <?> ""++{- | Consumes a multi-line comment+ MultiLineComment_t ::=+ '{ -- }'+ | '{ -' ~DocCommentMarker_t InCommentChars_t+ ;++ InCommentChars_t ::=+ '- }'+ | MultiLineComment_t InCommentChars_t+ | ~'- }'+ InCommentChars_t+ ;+ -}++multiLineComment :: MonadicParsing m => m ()+multiLineComment = try (string "{-" *> (string "-}") *> pure ())+ <|> string "{-" *> satisfy (not . isDocCommentMarker) *> inCommentChars+ <?> ""+ where inCommentChars :: MonadicParsing m => m ()+ inCommentChars = string "-}" *> pure ()+ <|> try (multiLineComment) *> inCommentChars+ <|> try (docComment '|') *> inCommentChars+ <|> try (docComment '^') *> inCommentChars+ <|> skipSome (noneOf startEnd) *> inCommentChars+ <|> oneOf startEnd *> inCommentChars+ <?> "end of comment"+ startEnd :: String+ startEnd = "{}-"++{-| Parses a documentation comment (similar to haddoc) given a marker character+ DocComment_t ::= '--' DocCommentMarker_t ~EOL_t* EOL_t+ | '{ -' DocCommentMarket_t ~'- }'* '- }'+ ;+ -}+docComment :: MonadicParsing m => Char -> m String+docComment marker | isDocCommentMarker marker = do dc <- docComment' marker; return (T.unpack $ T.strip $ T.pack dc)+ | otherwise = fail "internal error: tried to parse a documentation comment with invalid marker"+ where docComment' :: MonadicParsing m => Char -> m String+ docComment' marker = string "--" *> char marker *> many (satisfy (not . isEol)) <* eol+ <|> string "{-" *> char marker *> (manyTill anyChar (try (string "-}")) <?> "end of comment")+ <?> ""++-- | Parses some white space+whiteSpace :: MonadicParsing m => m ()+whiteSpace = Tok.whiteSpace++-- | Parses a string literal+stringLiteral :: MonadicParsing m => m String+stringLiteral = Tok.stringLiteral++-- | Parses a char literal+charLiteral :: MonadicParsing m => m Char+charLiteral = Tok.charLiteral++-- | Parses a natural number+natural :: MonadicParsing m => m Integer+natural = Tok.natural++-- | Parses an integral number+integer :: MonadicParsing m => m Integer+integer = Tok.integer++-- | Parses a floating point number+float :: MonadicParsing m => m Double+float = Tok.double++{- * Symbols, identifiers, names and operators -}+++-- | Idris Style for parsing identifiers/reserved keywords+idrisStyle :: MonadicParsing m => IdentifierStyle m+idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved Hi.Identifier Hi.ReservedIdentifier+ where _styleName = "Idris"+ _styleStart = satisfy isAlpha+ _styleLetter = satisfy isAlphaNum <|> oneOf "_'" <|> (lchar '.')+ _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "Type",+ "do", "dsl", "import", "impossible",+ "case", "of", "total", "partial", "mutual",+ "infix", "infixl", "infixr", "rewrite",+ "where", "with", "syntax", "proof", "postulate",+ "using", "namespace", "class", "instance",+ "public", "private", "abstract", "implicit",+ "quoteGoal",+ "Int", "Integer", "Float", "Char", "String", "Ptr",+ "Bits8", "Bits16", "Bits32", "Bits64",+ "Bits8x16", "Bits16x8", "Bits32x4", "Bits64x2"]++char :: MonadicParsing m => Char -> m Char+char = Chr.char++string :: MonadicParsing m => String -> m String+string = Chr.string++-- | Parses a character as a token+lchar :: MonadicParsing m => Char -> m Char+lchar = token . char++-- | Parses string as a token+symbol :: MonadicParsing m => String -> m String+symbol = Tok.symbol++-- | Parses a reserved identifier+reserved :: MonadicParsing m => String -> m ()+reserved = Tok.reserve idrisStyle++-- Taken from Parsec (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- | Parses a reserved operator+reservedOp :: MonadicParsing m => String -> m ()+reservedOp name = token $ try $+ do string name+ notFollowedBy (operatorLetter) <?> ("end of " ++ show name)++-- | Parses an identifier as a token+identifier :: MonadicParsing m => m String+identifier = token $ Tok.ident idrisStyle++-- | Parses an identifier with possible namespace as a name+iName :: MonadicParsing m => [String] -> m Name+iName bad = maybeWithNS identifier False bad <?> "name"++-- | Parses an string possibly prefixed by a namespace+maybeWithNS :: MonadicParsing m => m String -> Bool -> [String] -> m Name+maybeWithNS parser ascend bad = do+ i <- option "" (lookAhead identifier)+ when (i `elem` bad) $ unexpected "reserved identifier"+ let transf = if ascend then id else reverse+ (x, xs) <- choice (transf (parserNoNS parser : parsersNS parser i))+ return $ mkName (x, xs)+ where parserNoNS :: MonadicParsing m => m String -> m (String, String)+ parserNoNS parser = do x <- parser; return (x, "")+ parserNS :: MonadicParsing m => m String -> String -> m (String, String)+ parserNS parser ns = do xs <- string ns; lchar '.'; x <- parser; return (x, xs)+ parsersNS :: MonadicParsing m => m String -> String -> [m (String, String)]+ parsersNS parser i = [try (parserNS parser ns) | ns <- (initsEndAt (=='.') i)]++-- | Parses a name+name :: IdrisParser Name+name = do i <- get+ iName (syntax_keywords i)+ <?> "name"+++{- | List of all initial segments in ascending order of a list. Every such+ initial segment ends right before an element satisfying the given+ condition.+-}+initsEndAt :: (a -> Bool) -> [a] -> [[a]]+initsEndAt p [] = []+initsEndAt p (x:xs) | p x = [] : x_inits_xs+ | otherwise = x_inits_xs+ where x_inits_xs = [x : cs | cs <- initsEndAt p xs]+++{- | Create a `Name' from a pair of strings representing a base name and its+ namespace.+-}+mkName :: (String, String) -> Name+mkName (n, "") = UN n+mkName (n, ns) = NS (UN n) (reverse (parseNS ns))+ where parseNS x = case span (/= '.') x of+ (x, "") -> [x]+ (x, '.':y) -> x : parseNS y++operatorLetter :: MonadicParsing m => m Char+operatorLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"++-- | Parses an operator+operator :: MonadicParsing m => m String+operator = do op <- token . some $ operatorLetter+ when (op == ":") $ fail "(:) is not a valid operator"+ return op++{- * Position helpers -}+{- | Get filename from position (returns "(interactive)" when no source file is given) -}+fileName :: Delta -> String+fileName (Directed fn _ _ _ _) = UTF8.toString fn+fileName _ = "(interactive)"++{- | Get line number from position -}+lineNum :: Delta -> Int+lineNum (Lines l _ _ _) = fromIntegral l + 1+lineNum (Directed _ l _ _ _) = fromIntegral l + 1++{- | Get file position as FC -}+getFC :: MonadicParsing m => m FC+getFC = do s <- position+ let (dir, file) = splitFileName (fileName s)+ let f = if dir == addTrailingPathSeparator "." then file else fileName s+ return $ FC f (lineNum s)++{-* Syntax helpers-}+-- | Bind constraints to term+bindList :: (Name -> PTerm -> PTerm -> PTerm) -> [(Name, PTerm)] -> PTerm -> PTerm+bindList b [] sc = sc+bindList b ((n, t):bs) sc = b n t (bindList b bs sc)++{- * Layout helpers -}++-- | Push indentation to stack+pushIndent :: IdrisParser ()+pushIndent = do pos <- position+ ist <- get+ put (ist { indent_stack = (fromIntegral (column pos) + 1) : indent_stack ist })++-- | Pops indentation from stack+popIndent :: IdrisParser ()+popIndent = do ist <- get+ let (x : xs) = indent_stack ist+ put (ist { indent_stack = xs })+++-- | Gets current indentation+indent :: IdrisParser Int+indent = liftM ((+1) . fromIntegral . column) position++-- | Gets last indentation+lastIndent :: IdrisParser Int+lastIndent = do ist <- get+ case indent_stack ist of+ (x : xs) -> return x+ _ -> return 1++-- | Applies parser in an indented position+indented :: IdrisParser a -> IdrisParser a+indented p = notEndBlock *> p <* keepTerminator++-- | Applies parser to get a block (which has possibly indented statements)+indentedBlock :: IdrisParser a -> IdrisParser [a]+indentedBlock p = do openBlock+ pushIndent+ res <- many (indented p)+ popIndent+ closeBlock+ return res++-- | Applies parser to get a block with at least one statement (which has possibly indented statements)+indentedBlock1 :: IdrisParser a -> IdrisParser [a]+indentedBlock1 p = do openBlock+ pushIndent+ res <- some (indented p)+ popIndent+ closeBlock+ return res++-- | Applies parser to get a block with exactly one (possibly indented) statement+indentedBlockS :: IdrisParser a -> IdrisParser a+indentedBlockS p = do openBlock+ pushIndent+ res <- indented p+ popIndent+ closeBlock+ return res+++-- | Checks if the following character matches provided parser+lookAheadMatches :: MonadicParsing m => m a -> m Bool+lookAheadMatches p = do match <- lookAhead (optional p)+ return $ isJust match++-- | Parses a start of block+openBlock :: IdrisParser ()+openBlock = do lchar '{'+ ist <- get+ put (ist { brace_stack = Nothing : brace_stack ist })+ <|> do ist <- get+ lvl' <- indent+ -- if we're not indented further, it's an empty block, so+ -- increment lvl to ensure we get to the end+ let lvl = case brace_stack ist of+ Just lvl_old : _ ->+ if lvl' <= lvl_old then lvl_old+1+ else lvl'+ [] -> if lvl' == 1 then 2 else lvl'+ _ -> lvl'+ put (ist { brace_stack = Just lvl : brace_stack ist })+ <?> "start of block"++-- | Parses an end of block+closeBlock :: IdrisParser ()+closeBlock = do ist <- get+ bs <- case brace_stack ist of+ [] -> eof >> return []+ Nothing : xs -> lchar '}' >> return xs <?> "end of block"+ Just lvl : xs -> (do i <- indent+ isParen <- lookAheadMatches (char ')')+ if i >= lvl && not isParen+ then fail "not end of block"+ else return xs)+ <|> (do notOpenBraces+ eof+ return [])+ put (ist { brace_stack = bs })++-- | Parses a terminator+terminator :: IdrisParser ()+terminator = do lchar ';'; popIndent+ <|> do c <- indent; l <- lastIndent+ if c <= l then popIndent else fail "not a terminator"+ <|> do isParen <- lookAheadMatches (oneOf ")}")+ if isParen then popIndent else fail "not a terminator"+ <|> lookAhead eof++-- | Parses and keeps a terminator+keepTerminator :: IdrisParser ()+keepTerminator = do lchar ';'; return ()+ <|> do c <- indent; l <- lastIndent+ unless (c <= l) $ fail "not a terminator"+ <|> do isParen <- lookAheadMatches (oneOf ")}|")+ unless isParen $ fail "not a terminator"+ <|> lookAhead eof++-- | Checks if application expression does not end+notEndApp :: IdrisParser ()+notEndApp = do c <- indent; l <- lastIndent+ when (c <= l) (fail "terminator")++-- | Checks that it is not end of block+notEndBlock :: IdrisParser ()+notEndBlock = do ist <- get+ case brace_stack ist of+ Just lvl : xs -> do i <- indent+ isParen <- lookAheadMatches (char ')')+ when (i < lvl || isParen) (fail "end of block")+ _ -> return ()++notOpenBraces :: IdrisParser ()+notOpenBraces = do ist <- get+ when (hasNothing $ brace_stack ist) $ fail "end of input"+ where hasNothing :: [Maybe a] -> Bool+ hasNothing = any isNothing++{- | Parses an accessibilty modifier (e.g. public, private) -}+accessibility :: IdrisParser Accessibility+accessibility = do reserved "public"; return Public+ <|> do reserved "abstract"; return Frozen+ <|> do reserved "private"; return Hidden+ <?> "accessibility modifier"++-- | Adds accessibility option for function+addAcc :: Name -> Maybe Accessibility -> IdrisParser ()+addAcc n a = do i <- get+ put (i { hide_list = (n, a) : hide_list i })++{- | Add accessbility option for data declarations+ (works for classes too - 'abstract' means the data/class is visible but members not) -}+accData :: Maybe Accessibility -> Name -> [Name] -> IdrisParser ()+accData (Just Frozen) n ns = do addAcc n (Just Frozen)+ mapM_ (\n -> addAcc n (Just Hidden)) ns+accData a n ns = do addAcc n a+ mapM_ (`addAcc` a) ns+++{- * Error reporting helpers -}+{- | Error message with possible fixes list -}+fixErrorMsg :: String -> [String] -> String+fixErrorMsg msg fixes = msg ++ ", possible fixes:\n" ++ (concat $ intersperse "\n\nor\n\n" fixes)++-- | Collect 'PClauses' with the same function name+collect :: [PDecl] -> [PDecl]+collect (c@(PClauses _ o _ _) : ds)+ = clauses (cname c) [] (c : ds)+ where clauses :: Maybe Name -> [PClause] -> [PDecl] -> [PDecl]+ clauses j@(Just n) acc (PClauses fc _ _ [PClause fc' n' l ws r w] : ds)+ | n == n' = clauses j (PClause fc' n' l ws r (collect w) : acc) ds+ clauses j@(Just n) acc (PClauses fc _ _ [PWith fc' n' l ws r w] : ds)+ | n == n' = clauses j (PWith fc' n' l ws r (collect w) : acc) ds+ clauses (Just n) acc xs = PClauses (fcOf c) o n (reverse acc) : collect xs+ clauses Nothing acc (x:xs) = collect xs+ clauses Nothing acc [] = []++ cname :: PDecl -> Maybe Name+ cname (PClauses fc _ _ [PClause _ n _ _ _ _]) = Just n+ cname (PClauses fc _ _ [PWith _ n _ _ _ _]) = Just n+ cname (PClauses fc _ _ [PClauseR _ _ _ _]) = Nothing+ cname (PClauses fc _ _ [PWithR _ _ _ _]) = Nothing+ fcOf :: PDecl -> FC+ fcOf (PClauses fc _ _ _) = fc+collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds+collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds+collect (PNamespace ns ps : ds) = PNamespace ns (collect ps) : collect ds+collect (PClass doc f s cs n ps ds : ds') + = PClass doc f s cs n ps (collect ds) : collect ds'+collect (PInstance f s cs n ps t en ds : ds') + = PInstance f s cs n ps t en (collect ds) : collect ds'+collect (d : ds) = d : collect ds+collect [] = []+
+ src/Idris/ParseOps.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}+module Idris.ParseOps where++import Prelude hiding (pi)++import Text.Trifecta.Delta+import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)+import Text.Parser.LookAhead+import Text.Parser.Expression+import qualified Text.Parser.Token as Tok+import qualified Text.Parser.Char as Chr+import qualified Text.Parser.Token.Highlight as Hi++import Idris.AbsSyntax+import Idris.ParseHelpers++import Core.TT++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict++import Data.Maybe+import qualified Data.List.Split as Spl+import Data.List+import Data.Monoid+import Data.Char+import qualified Data.HashSet as HS+import qualified Data.Text as T+import qualified Data.ByteString.UTF8 as UTF8++{- |Creates table for fixity declarations to build expression parser using+ pre-build and user-defined operator/fixity declarations -}+table :: [FixDecl] -> OperatorTable IdrisParser PTerm+table fixes+ = [[prefix "-" (\fc x -> PApp fc (PRef fc (UN "-"))+ [pexp (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]+ ++ toTable (reverse fixes) +++ [[backtick],+ [binary "=" PEq AssocLeft],+ [binary "->" (\fc x y -> PPi expl (MN 42 "__pi_arg") x y) AssocRight]]++{- |Calculates table for fixtiy declarations -}+toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm+toTable fs = map (map toBin)+ (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)+ where toBin (Fix (PrefixN _) op) = prefix op+ (\fc x -> PApp fc (PRef fc (UN op)) [pexp x])+ toBin (Fix f op)+ = binary op (\fc x y -> PApp fc (PRef fc (UN op)) [pexp x,pexp y]) (assoc f)+ assoc (Infixl _) = AssocLeft+ assoc (Infixr _) = AssocRight+ assoc (InfixN _) = AssocNone++{- |Binary operator -}+binary :: String -> (FC -> PTerm -> PTerm -> PTerm) -> Assoc -> Operator IdrisParser PTerm+binary name f = Infix (do fc <- getFC+ reservedOp name+ doc <- option "" (docComment '^')+ return (f fc))++{- |Prefix operator -}+prefix :: String -> (FC -> PTerm -> PTerm) -> Operator IdrisParser PTerm+prefix name f = Prefix (do reservedOp name+ fc <- getFC+ return (f fc))++{- |Backtick operator -}+backtick :: Operator IdrisParser PTerm+backtick = Infix (do lchar '`'; n <- fnName+ lchar '`'+ fc <- getFC+ return (\x y -> PApp fc (PRef fc n) [pexp x, pexp y])) AssocNone++{- | Parses an operator in function position i.e. enclosed by `()', with an+ optional namespace++ OperatorFront ::= (Identifier_t '.')? '(' Operator_t ')';+-}+operatorFront :: IdrisParser Name+operatorFront = maybeWithNS (lchar '(' *> operator <* lchar ')') False []++{- | Parses a function (either normal name or operator)+ FnName ::= Name | OperatorFront;+-}+fnName :: IdrisParser Name+fnName = try operatorFront <|> name <?> "function name"++{- | Parses a fixity declaration++Fixity ::=+ FixityType Natural_t OperatorList Terminator+ ;+-}+fixity :: IdrisParser PDecl+fixity = do pushIndent+ f <- fixityType; i <- natural; ops <- sepBy1 operator (lchar ',')+ terminator+ let prec = fromInteger i+ istate <- get+ let infixes = idris_infixes istate+ let fs = map (Fix (f prec)) ops+ let redecls = map (alreadyDeclared infixes) fs+ let ill = filter (not . checkValidity) redecls+ if null ill+ then do put (istate { idris_infixes = nub $ sort (fs ++ infixes)+ , ibc_write = map IBCFix fs ++ ibc_write istate+ })+ fc <- getFC+ return (PFix fc (f prec) ops)+ else fail $ concatMap (\(f, (x:xs)) -> "Illegal redeclaration of fixity:\n\t\""+ ++ show f ++ "\" overrides \"" ++ show x ++ "\"") ill+ <?> "fixity declaration"+ where alreadyDeclared :: [FixDecl] -> FixDecl -> (FixDecl, [FixDecl])+ alreadyDeclared fs f = (f, filter ((extractName f ==) . extractName) fs)++ checkValidity :: (FixDecl, [FixDecl]) -> Bool+ checkValidity (f, fs) = all (== f) fs++ extractName :: FixDecl -> String+ extractName (Fix _ n) = n++{- | Parses a fixity declaration type (i.e. infix or prefix, associtavity)+FixityType ::=+ 'infixl'+ | 'infixr'+ | 'infix'+ | 'prefix'+ ;+ -}+fixityType :: IdrisParser (Int -> Fixity)+fixityType = do reserved "infixl"; return Infixl+ <|> do reserved "infixr"; return Infixr+ <|> do reserved "infix"; return InfixN+ <|> do reserved "prefix"; return PrefixN+ <?> "fixity type"+
src/Idris/Parser.hs view
@@ -1,2772 +1,1054 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}-module Idris.Parser where--import Prelude hiding (pi)--import Text.Trifecta.Delta-import Text.Trifecta hiding (span, token, whiteSpace, stringLiteral, charLiteral, natural, symbol, char, string)-import Text.Parser.LookAhead-import Text.Parser.Expression-import qualified Text.Parser.Token as Tok-import qualified Text.Parser.Char as Chr-import qualified Text.Parser.Token.Highlight as Hi--import Idris.AbsSyntax-import Idris.DSL-import Idris.Imports-import Idris.Error-import Idris.ElabDecls-import Idris.ElabTerm hiding (namespace, params)-import Idris.Coverage-import Idris.IBC-import Idris.Unlit-import Idris.Providers-import Paths_idris--import Util.DynamicLinker--import Core.TT-import Core.Evaluate--import Control.Applicative-import Control.Monad-import Control.Monad.State.Strict--import Data.Maybe-import qualified Data.List.Split as Spl-import Data.List-import Data.Monoid-import Data.Char-import qualified Data.HashSet as HS-import qualified Data.Text as T-import qualified Data.ByteString.UTF8 as UTF8--import Debug.Trace--import System.FilePath-{-- grammar shortcut notation:- ~CHARSEQ = complement of char sequence (i.e. any character except CHARSEQ)- RULE? = optional rule (i.e. RULE or nothing)- RULE* = repeated rule (i.e. RULE zero or more times)- RULE+ = repeated rule with at least one match (i.e. RULE one or more times)- RULE! = invalid rule (i.e. rule that is not valid in context, report meaningful error in case)- RULE{n} = rule repeated n times--}----- | Idris parser with state used during parsing-type IdrisParser = StateT IState Parser---- | Generalized monadic parsing constraint type-type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m)--{- * Space, comments and literals (token/lexing like parsers) -}--- | Parses a token by applying parser and then consuming all following whiteSpace-lexeme :: MonadicParsing m => m a -> m a-lexeme p = p <* whiteSpace---- | Consumes any simple whitespace (any character which satisfies Char.isSpace)-simpleWhiteSpace :: MonadicParsing m => m ()-simpleWhiteSpace = satisfy isSpace *> pure ()---- | Checks if a charcter is end of line-isEol :: Char -> Bool-isEol '\n' = True-isEol '\0' = True -- Check eof too-isEol _ = False---- | Checks if a character is a documentation comment marker-isDocCommentMarker :: Char -> Bool-isDocCommentMarker '|' = True-isDocCommentMarker '^' = True-isDocCommentMarker _ = False--{- | Consumes a single-line comment- SingleLineComment_t ::= '--' EOL_t- | '--' ~DocCommentMarker_t ~EOL_t* EOL_t- ;- -}-singleLineComment :: MonadicParsing m => m ()-singleLineComment = try (string "--" *> satisfy isEol *> pure ())- <|> try (string "--" *> satisfy (not . isDocCommentMarker) *> many (satisfy (not . isEol)) *> (satisfy isEol <?> "end of line") *> pure ())- <?> "single-line comment"--{- | Consumes a multi-line comment- MultiLineComment_t ::=- '{ -- }'- | '{ -' ~DocCommentMarker_t InCommentChars_t- ;-- InCommentChars_t ::=- '- }'- | MultiLineComment_t InCommentChars_t- | ~'- }'+ InCommentChars_t- ;- -}--multiLineComment :: MonadicParsing m => m ()-multiLineComment = try (string "{-" *> (string "-}") *> pure ())- <|> try (string "{-" *> satisfy (not . isDocCommentMarker) *> inCommentChars)- <?> "multi-line comment"- where inCommentChars :: MonadicParsing m => m ()- inCommentChars = try (string "-}" *> pure ())- <|> try (multiLineComment *> inCommentChars)- <|> try (docComment '|' *> inCommentChars)- <|> try (docComment '^' *> inCommentChars)- <|> try (skipSome (noneOf startEnd) *> inCommentChars)- <|> oneOf startEnd *> inCommentChars- <?> "end of comment"- startEnd :: String- startEnd = "{}-"--{-| Parses a documentation comment (similar to haddoc) given a marker character- DocComment_t ::= '--' DocCommentMarker_t ~EOL_t* EOL_t- | '{ -' DocCommentMarket_t ~'- }'* '- }'- ;- -}-docComment :: MonadicParsing m => Char -> m String-docComment marker | isDocCommentMarker marker = do dc <- docComment' marker; return (T.unpack $ T.strip $ T.pack dc)- | otherwise = fail "internal error: tried to parse a documentation comment with invalid marker"- where docComment' :: MonadicParsing m => Char -> m String- docComment' marker = string "--" *> char marker *> many (satisfy (not . isEol)) <* satisfy isEol- <|> string "{-" *> char marker *> (manyTill anyChar (try (string "-}")) <?> "end of comment")- <?> "documentation comment"---- | Consumes whitespace (and comments)-whiteSpace :: MonadicParsing m => m ()-whiteSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()---- | Parses a string literal-stringLiteral :: MonadicParsing m => m String-stringLiteral = lexeme $ Tok.stringLiteral---- | Parses a char literal-charLiteral :: MonadicParsing m => m Char-charLiteral = lexeme $ Tok.charLiteral---- | Parses a natural number-natural :: MonadicParsing m => m Integer-natural = lexeme $ Tok.natural---- | Parses an integral number-integer :: MonadicParsing m => m Integer-integer = lexeme $ Tok.integer---- | Parses a floating point number-float :: MonadicParsing m => m Double-float = lexeme $ Tok.double--{- * Symbols, identifiers, names and operators -}----- | Idris Style for parsing identifiers/reserved keywords-idrisStyle :: MonadicParsing m => IdentifierStyle m-idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved Hi.Identifier Hi.ReservedIdentifier- where _styleName = "Idris"- _styleStart = satisfy isAlpha- _styleLetter = satisfy isAlphaNum <|> oneOf "_'" <|> (lchar '.')- _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "Type",- "do", "dsl", "import", "impossible",- "case", "of", "total", "partial", "mutual",- "infix", "infixl", "infixr", "rewrite",- "where", "with", "syntax", "proof", "postulate",- "using", "namespace", "class", "instance",- "public", "private", "abstract", "implicit",- "quoteGoal",- "Int", "Integer", "Float", "Char", "String", "Ptr",- "Bits8", "Bits16", "Bits32", "Bits64",- "Bits8x16", "Bits16x8", "Bits32x4", "Bits64x2"]--char :: MonadicParsing m => Char -> m Char-char = Chr.char--string :: MonadicParsing m => String -> m String-string = Chr.string---- | Parses a character as a lexeme-lchar :: MonadicParsing m => Char -> m Char-lchar = lexeme . char---- | Parses string as a lexeme-symbol :: MonadicParsing m => String -> m String-symbol = lexeme . Tok.symbol---- | Parses a reserved identifier-reserved :: MonadicParsing m => String -> m ()-reserved = lexeme . Tok.reserve idrisStyle---- Taken from Parsec (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007--- | Parses a reserved operator-reservedOp :: MonadicParsing m => String -> m ()-reservedOp name = lexeme $ try $- do string name- notFollowedBy (operatorLetter) <?> ("end of " ++ show name)---- | Parses an identifier as a lexeme-identifier :: MonadicParsing m => m String-identifier = lexeme $ Tok.ident idrisStyle---- | Parses an identifier with possible namespace as a name-iName :: MonadicParsing m => [String] -> m Name-iName bad = maybeWithNS identifier False bad <?> "name"---- | Parses an string possibly prefixed by a namespace-maybeWithNS :: MonadicParsing m => m String -> Bool -> [String] -> m Name-maybeWithNS parser ascend bad = do- i <- option "" (lookAhead identifier)- when (i `elem` bad) $ unexpected "reserved identifier"- let transf = if ascend then id else reverse- (x, xs) <- choice (transf (parserNoNS parser : parsersNS parser i))- return $ mkName (x, xs)- where parserNoNS :: MonadicParsing m => m String -> m (String, String)- parserNoNS parser = do x <- parser; return (x, "")- parserNS :: MonadicParsing m => m String -> String -> m (String, String)- parserNS parser ns = do xs <- string ns; lchar '.'; x <- parser; return (x, xs)- parsersNS :: MonadicParsing m => m String -> String -> [m (String, String)]- parsersNS parser i = [try (parserNS parser ns) | ns <- (initsEndAt (=='.') i)]---- | Parses a name-name :: IdrisParser Name-name = do i <- get- iName (syntax_keywords i)- <?> "name"---{- | List of all initial segments in ascending order of a list. Every such- initial segment ends right before an element satisfying the given- condition.--}-initsEndAt :: (a -> Bool) -> [a] -> [[a]]-initsEndAt p [] = []-initsEndAt p (x:xs) | p x = [] : x_inits_xs- | otherwise = x_inits_xs- where x_inits_xs = [x : cs | cs <- initsEndAt p xs]---{- | Create a `Name' from a pair of strings representing a base name and its- namespace.--}-mkName :: (String, String) -> Name-mkName (n, "") = UN n-mkName (n, ns) = NS (UN n) (reverse (parseNS ns))- where parseNS x = case span (/= '.') x of- (x, "") -> [x]- (x, '.':y) -> x : parseNS y--operatorLetter :: MonadicParsing m => m Char-operatorLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"---- | Parses an operator-operator :: MonadicParsing m => m String-operator = lexeme . some $ operatorLetter--{- * Position helpers -}-{- | Get filename from position (returns "(interactive)" when no source file is given) -}-fileName :: Delta -> String-fileName (Directed fn _ _ _ _) = UTF8.toString fn-fileName _ = "(interactive)"--{- | Get line number from position -}-lineNum :: Delta -> Int-lineNum (Lines l _ _ _) = fromIntegral l + 1-lineNum (Directed _ l _ _ _) = fromIntegral l + 1--{- | Get file position as FC -}-getFC :: MonadicParsing m => m FC-getFC = do s <- position- let (dir, file) = splitFileName (fileName s)- let f = if dir == addTrailingPathSeparator "." then file else fileName s- return $ FC f (lineNum s)--{-* Syntax helpers-}--- | Bind constraints to term-bindList :: (Name -> PTerm -> PTerm -> PTerm) -> [(Name, PTerm)] -> PTerm -> PTerm-bindList b [] sc = sc-bindList b ((n, t):bs) sc = b n t (bindList b bs sc)--{- |Creates table for fixtiy declarations to build expression parser using- pre-build and user-defined operator/fixity declarations -}-table :: [FixDecl] -> OperatorTable IdrisParser PTerm-table fixes- = [[prefix "-" (\fc x -> PApp fc (PRef fc (UN "-"))- [pexp (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]- ++ toTable (reverse fixes) ++- [[backtick],- [binary "=" PEq AssocLeft],- [binary "->" (\fc x y -> PPi expl (MN 42 "__pi_arg") x y) AssocRight]]--{- |Calculates table for fixtiy declarations -}-toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm-toTable fs = map (map toBin)- (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)- where toBin (Fix (PrefixN _) op) = prefix op- (\fc x -> PApp fc (PRef fc (UN op)) [pexp x])- toBin (Fix f op)- = binary op (\fc x y -> PApp fc (PRef fc (UN op)) [pexp x,pexp y]) (assoc f)- assoc (Infixl _) = AssocLeft- assoc (Infixr _) = AssocRight- assoc (InfixN _) = AssocNone--{- |Binary operator -}-binary :: String -> (FC -> PTerm -> PTerm -> PTerm) -> Assoc -> Operator IdrisParser PTerm-binary name f = Infix (do fc <- getFC- reservedOp name- doc <- option "" (docComment '^')- return (f fc))--{- |Prefix operator -}-prefix :: String -> (FC -> PTerm -> PTerm) -> Operator IdrisParser PTerm-prefix name f = Prefix (do reservedOp name- fc <- getFC- return (f fc))--{- |Backtick operator -}-backtick :: Operator IdrisParser PTerm-backtick = Infix (do lchar '`'; n <- fnName- lchar '`'- fc <- getFC- return (\x y -> PApp fc (PRef fc n) [pexp x, pexp y])) AssocNone---- | Allow implicit type declarations-allowImp :: SyntaxInfo -> SyntaxInfo-allowImp syn = syn { implicitAllowed = True }---- | Disallow implicit type declarations-disallowImp :: SyntaxInfo -> SyntaxInfo-disallowImp syn = syn { implicitAllowed = False }---- | Adds accessibility option for function-addAcc :: Name -> Maybe Accessibility -> IdrisParser ()-addAcc n a = do i <- get- put (i { hide_list = (n, a) : hide_list i })--{- | Add accessbility option for data declarations- (works for classes too - 'abstract' means the data/class is visible but members not) -}-accData :: Maybe Accessibility -> Name -> [Name] -> IdrisParser ()-accData (Just Frozen) n ns = do addAcc n (Just Frozen)- mapM_ (\n -> addAcc n (Just Hidden)) ns-accData a n ns = do addAcc n a- mapM_ (`addAcc` a) ns---{- * Error reporting helpers -}-{- | Error message with possible fixes list -}-fixErrorMsg :: String -> [String] -> String-fixErrorMsg msg fixes = msg ++ ", possible fixes:\n" ++ (concat $ intersperse "\n\nor\n\n" fixes)--{- * Layout helpers -}---- | Push indentation to stack-pushIndent :: IdrisParser ()-pushIndent = do pos <- position- ist <- get- put (ist { indent_stack = (fromIntegral (column pos) + 1) : indent_stack ist })---- | Pops indentation from stack-popIndent :: IdrisParser ()-popIndent = do ist <- get- let (x : xs) = indent_stack ist- put (ist { indent_stack = xs })---- | Gets current indentation-indent :: IdrisParser Int-indent = liftM ((+1) . fromIntegral . column) position---- | Gets last indentation-lastIndent :: IdrisParser Int-lastIndent = do ist <- get- case indent_stack ist of- (x : xs) -> return x- _ -> return 1---- | Applies parser in an indented position-indented :: IdrisParser a -> IdrisParser a-indented p = notEndBlock *> p <* keepTerminator---- | Applies parser to get a block (which has possibly indented statements)-indentedBlock :: IdrisParser a -> IdrisParser [a]-indentedBlock p = do openBlock- pushIndent- res <- many (indented p)- popIndent- closeBlock- return res---- | Applies parser to get a block with at least one statement (which has possibly indented statements)-indentedBlock1 :: IdrisParser a -> IdrisParser [a]-indentedBlock1 p = do openBlock- pushIndent- res <- some (indented p)- popIndent- closeBlock- return res---- | Applies parser to get a block with exactly one (possibly indented) statement-indentedBlockS :: IdrisParser a -> IdrisParser a-indentedBlockS p = do openBlock- pushIndent- res <- indented p- popIndent- closeBlock- return res----- | Checks if the following character matches provided parser-lookAheadMatches :: MonadicParsing m => m a -> m Bool-lookAheadMatches p = do match <- lookAhead (optional p)- return $ isJust match---- | Parses a start of block-openBlock :: IdrisParser ()-openBlock = do lchar '{'- ist <- get- put (ist { brace_stack = Nothing : brace_stack ist })- <|> do ist <- get- lvl' <- indent- -- if we're not indented further, it's an empty block, so- -- increment lvl to ensure we get to the end- let lvl = case brace_stack ist of- Just lvl_old : _ ->- if lvl' <= lvl_old then lvl_old+1- else lvl'- [] -> if lvl' == 1 then 2 else lvl'- _ -> lvl'- put (ist { brace_stack = Just lvl : brace_stack ist })- <?> "start of block"---- | Parses an end of block-closeBlock :: IdrisParser ()-closeBlock = do ist <- get- bs <- case brace_stack ist of- [] -> eof >> return []- Nothing : xs -> lchar '}' >> return xs <?> "end of block"- Just lvl : xs -> (do i <- indent- isParen <- lookAheadMatches (char ')')- if i >= lvl && not isParen- then fail "not end of block"- else return xs)- <|> (do notOpenBraces- eof- return [])- put (ist { brace_stack = bs })---- | Parses a terminator-terminator :: IdrisParser ()-terminator = do lchar ';'; popIndent- <|> do c <- indent; l <- lastIndent- if c <= l then popIndent else fail "not a terminator"- <|> do isParen <- lookAheadMatches (oneOf ")}")- if isParen then popIndent else fail "not a termiantor"- <|> lookAhead eof---- | Parses and keeps a terminator-keepTerminator :: IdrisParser ()-keepTerminator = do lchar ';'; return ()- <|> do c <- indent; l <- lastIndent- unless (c <= l) $ fail "not a terminator"- <|> do isParen <- lookAheadMatches (oneOf ")}|")- unless isParen $ fail "not a terminator"- <|> lookAhead eof---- | Checks if application expression does not end-notEndApp :: IdrisParser ()-notEndApp = do c <- indent; l <- lastIndent- when (c <= l) (fail "terminator")---- | Checks that it is not end of block-notEndBlock :: IdrisParser ()-notEndBlock = do ist <- get- case brace_stack ist of- Just lvl : xs -> do i <- indent- isParen <- lookAheadMatches (char ')')- when (i < lvl || isParen) (fail "end of block")- _ -> return ()--notOpenBraces :: IdrisParser ()-notOpenBraces = do ist <- get- when (hasNothing $ brace_stack ist) $ fail "end of input"- where hasNothing :: [Maybe a] -> Bool- hasNothing = any isNothing--{- * Main grammar -}--{- | Parses module definition- ModuleHeader ::= 'module' Identifier_t ';'?;--}-moduleHeader :: IdrisParser [String]-moduleHeader = try (do reserved "module"- i <- identifier- option ';' (lchar ';')- return (moduleName i))- <|> return []- where moduleName x = case span (/='.') x of- (x, "") -> [x]- (x, '.':y) -> x : moduleName y--{- | Parses an import statement- Import ::= 'import' Identifier_t ';'?;- -}-import_ :: IdrisParser String-import_ = do reserved "import"- id <- identifier- option ';' (lchar ';')- return (toPath id)- <?> "import statement"- where toPath f = foldl1' (</>) (Spl.splitOn "." f)--{- | Parses program source- Prog ::= Decl* EOF;- -}-prog :: SyntaxInfo -> IdrisParser [PDecl]-prog syn = do whiteSpace- decls <- many (decl syn)- notOpenBraces- eof- let c = (concat decls)- return c--{- | Parses a top-level declaration-Decl ::=- Decl'- | Using- | Params- | Mutual- | Namespace- | Class- | Instance- | DSL- | Directive- | Provider- | Transform- | Import!- ;--}-decl :: SyntaxInfo -> IdrisParser [PDecl]-decl syn = do notEndBlock- declBody- where declBody :: IdrisParser [PDecl]- declBody = declBody'- <|> using_ syn- <|> params syn- <|> mutual syn- <|> namespace syn- <|> class_ syn- <|> instance_ syn- <|> do d <- dsl syn; return [d]- <|> directive syn- <|> try(provider syn)- <|> transform syn- <|> try(do import_; fail "imports must be at top of file")- <?> "declaration"- declBody' :: IdrisParser [PDecl]- declBody' = do d <- decl' syn- i <- get- let d' = fmap (desugar syn i) d- return [d']--{- | Parses a top-level declaration with possible syntax sugar-Decl' ::=- Fixity- | FunDecl'- | Data- | Record- | SyntaxDecl- ;--}-decl' :: SyntaxInfo -> IdrisParser PDecl-decl' syn = try fixity- <|> try (fnDecl' syn)- <|> try (data_ syn)- <|> try (record syn)- <|> try (syntaxDecl syn)- <?> "declaration"--{- | Parses a syntax extension declaration (and adds the rule to parser state)- SyntaxDecl ::= SyntaxRule;--}-syntaxDecl :: SyntaxInfo -> IdrisParser PDecl-syntaxDecl syn = do s <- syntaxRule syn- i <- get- let rs = syntax_rules i- let ns = syntax_keywords i- let ibc = ibc_write i- let ks = map show (names s)- put (i { syntax_rules = s : rs,- syntax_keywords = ks ++ ns,- ibc_write = IBCSyntax s : map IBCKeyword ks ++ ibc })- fc <- getFC- return (PSyntax fc s)- where names (Rule syms _ _) = mapMaybe ename syms- ename (Keyword n) = Just n- ename _ = Nothing--{- | Parses a syntax extension declaration-SyntaxRuleOpts ::= 'term' | 'pattern';--SyntaxRule ::=- SyntaxRuleOpts? 'syntax' SyntaxSym+ '=' TypeExpr Terminator;--SyntaxSym ::= '[' Name_t ']'- | '{' Name_t '}'- | Name_t- | StringLiteral_t- ;--}-syntaxRule :: SyntaxInfo -> IdrisParser Syntax-syntaxRule syn- = do pushIndent- sty <- option AnySyntax (do reserved "term"; return TermSyntax- <|> do reserved "pattern"; return PatternSyntax)- reserved "syntax"- syms <- some syntaxSym- when (all isExpr syms) $ unexpected "missing keywords in syntax rule"- let ns = mapMaybe getName syms- when (length ns /= length (nub ns))- $ unexpected "repeated variable in syntax rule"- lchar '='- tm <- typeExpr (allowImp syn)- terminator- return (Rule (mkSimple syms) tm sty)- where- isExpr (Expr _) = True- isExpr _ = False- getName (Expr n) = Just n- getName _ = Nothing- -- Can't parse two full expressions (i.e. expressions with application) in a row- -- so change them both to a simple expression- mkSimple (Expr e : es) = SimpleExpr e : mkSimple' es- mkSimple xs = mkSimple' xs-- mkSimple' (Expr e : Expr e1 : es) = SimpleExpr e : SimpleExpr e1 :- mkSimple es- mkSimple' (e : es) = e : mkSimple' es- mkSimple' [] = []---{- | Parses a syntax symbol (either binding variable, keyword or expression)-SyntaxSym ::= '[' Name_t ']'- | '{' Name_t '}'- | Name_t- | StringLiteral_t- ;- -}-syntaxSym :: IdrisParser SSymbol-syntaxSym = try (do lchar '['; n <- name; lchar ']'- return (Expr n))- <|> try (do lchar '{'; n <- name; lchar '}'- return (Binding n))- <|> do n <- iName []- return (Keyword n)- <|> do sym <- stringLiteral- return (Symbol sym)- <?> "syntax symbol"--{- | Parses a function declaration with possible syntax sugar- FunDecl ::= FunDecl';--}-fnDecl :: SyntaxInfo -> IdrisParser [PDecl]-fnDecl syn- = try (do notEndBlock- d <- fnDecl' syn- i <- get- let d' = fmap (desugar syn i) d- return [d'])- <?> "function declaration"--{- Parses a function declaration- FunDecl' ::=- DocComment_t? FnOpts* Accessibility? FnOpts* FnName TypeSig Terminator- | Postulate- | Pattern- | CAF- ;--}-fnDecl' :: SyntaxInfo -> IdrisParser PDecl-fnDecl' syn = try (do doc <- option "" (docComment '|')- pushIndent- ist <- get- let initOpts = if default_total ist- then [TotalFn]- else []- opts <- fnOpts initOpts- acc <- optional accessibility- opts' <- fnOpts opts- n_in <- fnName- let n = expandNS syn n_in- fc <- getFC- ty <- typeSig (allowImp syn)- terminator- addAcc n acc- return (PTy doc syn fc opts' n ty))- <|> try (postulate syn)- <|> try (pattern syn)- <|> try (caf syn)- <?> "function declaration"---{- Parses function options given initial options-FnOpts ::= 'total'- | 'partial'- | 'implicit'- | '%' 'assert_total'- | '%' 'reflection'- | '%' 'specialise' '[' NameTimesList? ']'- ;--NameTimes ::= FnName Natural?;--NameTimesList ::=- NameTimes- | NameTimes ',' NameTimesList- ;---}--- FIXME: Check compatability for function options (i.e. partal/total)-fnOpts :: [FnOpt] -> IdrisParser [FnOpt]-fnOpts opts- = do reserved "total"; fnOpts (TotalFn : opts)- <|> do reserved "partial"; fnOpts (PartialFn : (opts \\ [TotalFn]))- <|> try (do lchar '%'; reserved "export"; c <- stringLiteral;- fnOpts (CExport c : opts))- <|> try (do lchar '%'; reserved "assert_total";- fnOpts (AssertTotal : opts))- <|> try (do lchar '%'; reserved "reflection";- fnOpts (Reflection : opts))- <|> do lchar '%'; reserved "specialise";- lchar '['; ns <- sepBy nameTimes (lchar ','); lchar ']'- fnOpts (Specialise ns : opts)- <|> do reserved "implicit"; fnOpts (Implicit : opts)- <|> return opts- <?> "function modifier"- where nameTimes :: IdrisParser (Name, Maybe Int)- nameTimes = do n <- fnName- t <- option Nothing (do reds <- natural- return (Just (fromInteger reds)))- return (n, t)--{- | Parses an operator in function position i.e. enclosed by `()', with an- optional namespace-- OperatorFront ::= (Identifier_t '.')? '(' Operator_t ')';--}-operatorFront :: IdrisParser Name-operatorFront = maybeWithNS (lchar '(' *> operator <* lchar ')') False []--{- | Parses a function (either normal name or operator)- FnName ::= Name | OperatorFront;--}-fnName :: IdrisParser Name-fnName = try operatorFront <|> name <?> "function name"--{- | Parses an accessibilty modifier (e.g. public, private) -}-accessibility :: IdrisParser Accessibility-accessibility = do reserved "public"; return Public- <|> do reserved "abstract"; return Frozen- <|> do reserved "private"; return Hidden- <?> "accessibility modifier"----{- | Parses a postulate--Postulate ::=- DocComment_t? 'postulate' FnOpts* Accesibility? FnOpts* FnName TypeSig Terminator- ;--}-postulate :: SyntaxInfo -> IdrisParser PDecl-postulate syn = do doc <- option "" (docComment '|')- pushIndent- reserved "postulate"- ist <- get- let initOpts = if default_total ist- then [TotalFn]- else []- opts <- fnOpts initOpts- acc <- optional accessibility- opts' <- fnOpts opts- n_in <- fnName- let n = expandNS syn n_in- ty <- typeSig (allowImp syn)- fc <- getFC- terminator- addAcc n acc- return (PPostulate doc syn fc opts' n ty)- <?> "postulate"--{- | Parses a using declaration--Using ::=- 'using' '(' UsingDeclList ')' OpenBlock Decl* CloseBlock- ;- -}-using_ :: SyntaxInfo -> IdrisParser [PDecl]-using_ syn =- do reserved "using"; lchar '('; ns <- usingDeclList syn; lchar ')'- openBlock- let uvars = using syn- ds <- many (decl (syn { using = uvars ++ ns }))- closeBlock- return (concat ds)- <?> "using declaration"--{- | Parses a parameters declaration--Params ::=- 'parameters' '(' TypeDeclList ')' OpenBlock Decl* CloseBlock- ;- -}-params :: SyntaxInfo -> IdrisParser [PDecl]-params syn =- do reserved "parameters"; lchar '('; ns <- typeDeclList syn; lchar ')'- openBlock- let pvars = syn_params syn- ds <- many (decl syn { syn_params = pvars ++ ns })- closeBlock- fc <- getFC- return [PParams fc ns (concat ds)]- <?> "parameters declaration"--{- | Parses a mutual declaration (for mutually recursive functions)--Mutual ::=- 'mutual' OpenBlock Decl* CloseBlock- ;--}-mutual :: SyntaxInfo -> IdrisParser [PDecl]-mutual syn =- do reserved "mutual"- openBlock- let pvars = syn_params syn- ds <- many (decl syn)- closeBlock- fc <- getFC- return [PMutual fc (concat ds)]- <?> "mutual block"--{- | Parses a namespace declaration--Namespace ::=- 'namespace' identifier OpenBlock Decl+ CloseBlock- ;--}-namespace :: SyntaxInfo -> IdrisParser [PDecl]-namespace syn =- do reserved "namespace"; n <- identifier;- openBlock- ds <- some (decl syn { syn_namespace = n : syn_namespace syn })- closeBlock- return [PNamespace n (concat ds)]- <?> "namespace declaration"--{- | Parses a fixity declaration--Fixity ::=- FixityType Natural_t OperatorList Terminator- ;--}-fixity :: IdrisParser PDecl-fixity = do pushIndent- f <- fixityType; i <- natural; ops <- sepBy1 operator (lchar ',')- terminator- let prec = fromInteger i- istate <- get- let infixes = idris_infixes istate- let fs = map (Fix (f prec)) ops- let redecls = map (alreadyDeclared infixes) fs- let ill = filter (not . checkValidity) redecls- if null ill- then do put (istate { idris_infixes = nub $ sort (fs ++ infixes)- , ibc_write = map IBCFix fs ++ ibc_write istate- })- fc <- getFC- return (PFix fc (f prec) ops)- else fail $ concatMap (\(f, (x:xs)) -> "Illegal redeclaration of fixity:\n\t\""- ++ show f ++ "\" overrides \"" ++ show x ++ "\"") ill- <?> "fixity declaration"- where alreadyDeclared :: [FixDecl] -> FixDecl -> (FixDecl, [FixDecl])- alreadyDeclared fs f = (f, filter ((extractName f ==) . extractName) fs)-- checkValidity :: (FixDecl, [FixDecl]) -> Bool- checkValidity (f, fs) = all (== f) fs-- extractName :: FixDecl -> String- extractName (Fix _ n) = n--{- | Parses a fixity declaration type (i.e. infix or prefix, associtavity)-FixityType ::=- 'infixl'- | 'infixr'- | 'infix'- | 'prefix'- ;- -}-fixityType :: IdrisParser (Int -> Fixity)-fixityType = try (do reserved "infixl"; return Infixl)- <|> try (do reserved "infixr"; return Infixr)- <|> try (do reserved "infix"; return InfixN)- <|> try (do reserved "prefix"; return PrefixN)- <?> "fixity type"--{- |Parses a methods block (for type classes and instances)- MethodsBlock ::= 'where' OpenBlock FnDecl* CloseBlock- -}-methodsBlock :: SyntaxInfo -> IdrisParser [PDecl]-methodsBlock syn = do reserved "where"- openBlock- ds <- many (fnDecl syn)- closeBlock- return (concat ds)- <?> "methods block"--{- |Parses a type class declaration--ClassArgument ::=- Name- | '(' Name ':' Expr ')'- ;--Class ::=- DocComment_t? Accessibility? 'class' ConstraintList? Name ClassArgument* MethodsBlock?- ;--}-class_ :: SyntaxInfo -> IdrisParser [PDecl]-class_ syn = do doc <- option "" (docComment '|')- acc <- optional accessibility- reserved "class"; fc <- getFC; cons <- constraintList syn; n_in <- name- let n = expandNS syn n_in- cs <- many carg- ds <- option [] (methodsBlock syn)- accData acc n (concatMap declared ds)- return [PClass doc syn fc cons n cs ds]- <?> "type-class declaration"- where- carg :: IdrisParser (Name, PTerm)- carg = do lchar '('; i <- name; lchar ':'; ty <- expr syn; lchar ')'- return (i, ty)- <|> do i <- name;- return (i, PType)--{- |Parses a type class instance declaration-- Instance ::=- 'instance' InstanceName? ConstraintList? Name SimpleExpr* MethodsBlock?- ;-- InstanceName ::= '[' Name ']';--}-instance_ :: SyntaxInfo -> IdrisParser [PDecl]-instance_ syn = do reserved "instance"; fc <- getFC- en <- optional instanceName- cs <- constraintList syn- cn <- name- args <- many (simpleExpr syn)- let sc = PApp fc (PRef fc cn) (map pexp args)- let t = bindList (PPi constraint) (map (\x -> (MN 0 "c", x)) cs) sc- ds <- option [] (methodsBlock syn)- return [PInstance syn fc cs cn args t en ds]- <?> "instance declaratioN"- where instanceName :: IdrisParser Name- instanceName = do lchar '['; n_in <- fnName; lchar ']'- let n = expandNS syn n_in- return n- <?> "instance name"---{- | Parses an expression as a whole- FullExpr ::= Expr EOF_t;- -}-fullExpr :: SyntaxInfo -> IdrisParser PTerm-fullExpr syn = do x <- expr syn- eof- i <- get- return $ desugar syn i x---{- |Parses an expression- Expr ::= Expr';--}-expr :: SyntaxInfo -> IdrisParser PTerm-expr syn = do i <- get- buildExpressionParser (table (idris_infixes i)) (expr' syn)--{- | Parses either an internally defined expression or- a user-defined one--Expr' ::= "External (User-defined) Syntax"- | InternalExpr;-- -}-expr' :: SyntaxInfo -> IdrisParser PTerm-expr' syn = try (externalExpr syn)- <|> internalExpr syn- <?> "expression"--{- | Parses a user-defined expression -}-externalExpr :: SyntaxInfo -> IdrisParser PTerm-externalExpr syn = do i <- get- extensions syn (syntax_rules i)- <?> "user-defined expression"--{- | Parses a simple user-defined expression -}-simpleExternalExpr :: SyntaxInfo -> IdrisParser PTerm-simpleExternalExpr syn = do i <- get- extensions syn (filter isSimple (syntax_rules i))- where- isSimple (Rule (Expr x:xs) _ _) = False- isSimple (Rule (SimpleExpr x:xs) _ _) = False- isSimple (Rule [Keyword _] _ _) = True- isSimple (Rule [Symbol _] _ _) = True- isSimple (Rule (_:xs) _ _) = case last xs of- Keyword _ -> True- Symbol _ -> True- _ -> False- isSimple _ = False--{- | Tries to parse a user-defined expression given a list of syntactic extensions -}-extensions :: SyntaxInfo -> [Syntax] -> IdrisParser PTerm-extensions syn rules = choice (map (try . extension syn) (filter isValid rules))- <?> "user-defined expression"- where- isValid :: Syntax -> Bool- isValid (Rule _ _ AnySyntax) = True- isValid (Rule _ _ PatternSyntax) = inPattern syn- isValid (Rule _ _ TermSyntax) = not (inPattern syn)---data SynMatch = SynTm PTerm | SynBind Name--{- | Tries to parse an expression given a user-defined rule -}-extension :: SyntaxInfo -> Syntax -> IdrisParser PTerm-extension syn (Rule ssym ptm _)- = do smap <- mapM extensionSymbol ssym- let ns = mapMaybe id smap- return (update ns ptm) -- updated with smap- where- extensionSymbol :: SSymbol -> IdrisParser (Maybe (Name, SynMatch))- extensionSymbol (Keyword n) = do reserved (show n); return Nothing- extensionSymbol (Expr n) = do tm <- expr syn- return $ Just (n, SynTm tm)- extensionSymbol (SimpleExpr n) = do tm <- simpleExpr syn- return $ Just (n, SynTm tm)- extensionSymbol (Binding n) = do b <- name- return $ Just (n, SynBind b)- extensionSymbol (Symbol s) = do symbol s- return Nothing- dropn :: Name -> [(Name, a)] -> [(Name, a)]- dropn n [] = []- dropn n ((x,t) : xs) | n == x = xs- | otherwise = (x,t):dropn n xs-- updateB :: [(Name, SynMatch)] -> Name -> Name- updateB ns n = case lookup n ns of- Just (SynBind t) -> t- _ -> n-- update :: [(Name, SynMatch)] -> PTerm -> PTerm- update ns (PRef fc n) = case lookup n ns of- Just (SynTm t) -> t- _ -> PRef fc n- update ns (PLam n ty sc) = PLam (updateB ns n) (update ns ty) (update (dropn n ns) sc)- update ns (PPi p n ty sc) = PPi p (updateB ns n) (update ns ty) (update (dropn n ns) sc)- update ns (PLet n ty val sc) = PLet (updateB ns n) (update ns ty) (update ns val)- (update (dropn n ns) sc)- update ns (PApp fc t args) = PApp fc (update ns t) (map (fmap (update ns)) args)- update ns (PCase fc c opts) = PCase fc (update ns c) (map (pmap (update ns)) opts)- update ns (PPair fc l r) = PPair fc (update ns l) (update ns r)- update ns (PDPair fc l t r) = PDPair fc (update ns l) (update ns t) (update ns r)- update ns (PAlternative a as) = PAlternative a (map (update ns) as)- update ns (PHidden t) = PHidden (update ns t)- update ns (PDoBlock ds) = PDoBlock $ upd ns ds- where upd :: [(Name, SynMatch)] -> [PDo] -> [PDo]- upd ns (DoExp fc t : ds) = DoExp fc (update ns t) : upd ns ds- upd ns (DoBind fc n t : ds) = DoBind fc n (update ns t) : upd (dropn n ns) ds- upd ns (DoLet fc n ty t : ds) = DoLet fc n (update ns ty) (update ns t)- : upd (dropn n ns) ds- upd ns (DoBindP fc i t : ds) = DoBindP fc (update ns i) (update ns t)- : upd ns ds- upd ns (DoLetP fc i t : ds) = DoLetP fc (update ns i) (update ns t)- : upd ns ds- update ns (PGoal fc r n sc) = PGoal fc (update ns r) n (update ns sc)- update ns t = t--{- |Parses a (normal) built-in expression--InternalExpr ::=- App- | MatchApp- | UnifyLog- | RecordType- | SimpleExpr- | Lambda- | QuoteGoal- | Let- | RewriteTerm- | Pi- | DoBlock- ;--}-internalExpr :: SyntaxInfo -> IdrisParser PTerm-internalExpr syn =- try (app syn)- <|> try (matchApp syn)- <|> try (unifyLog syn)- <|> recordType syn- <|> try (simpleExpr syn)- <|> lambda syn- <|> quoteGoal syn- <|> let_ syn- <|> rewriteTerm syn- <|> pi syn- <|> doBlock syn- <?> "expression"--{- | Parses a case expression-CaseExpr ::=- 'case' Expr 'of' OpenBlock CaseOption+ CloseBlock;--}-caseExpr :: SyntaxInfo -> IdrisParser PTerm-caseExpr syn = do reserved "case"; fc <- getFC- scr <- expr syn; reserved "of";- opts <- indentedBlock1 (caseOption syn)- return (PCase fc scr opts)- <?> "case expression"--{- | Parses a case in a case expression-CaseOption ::=- Expr '=>' Expr Terminator- ;--}-caseOption :: SyntaxInfo -> IdrisParser (PTerm, PTerm)-caseOption syn = do lhs <- expr (syn { inPattern = True })- symbol "=>"; r <- expr syn- return (lhs, r)- <?> "case option"--{- | Parses a proof block-ProofExpr ::=- 'proof' OpenBlock Tactic'* CloseBlock- ;--}-proofExpr :: SyntaxInfo -> IdrisParser PTerm-proofExpr syn = do reserved "proof"- ts <- indentedBlock (tactic syn)- return $ PProof ts- <?> "proof block"--{- | Parses a tactics block-TacticsExpr :=- 'tactics' OpenBlock Tactic'* CloseBlock-;--}-tacticsExpr :: SyntaxInfo -> IdrisParser PTerm-tacticsExpr syn = do reserved "tactics"- ts <- indentedBlock (tactic syn)- return $ PTactics ts- <?> "tactics block"--{- | Parses a simple expresion-SimpleExpr ::=- '![' Term ']'- | '?' Name- | % 'instance'- | 'refl' ('{' Expr '}')?- | ProofExpr- | TacticsExpr- | CaseExpr- | FnName- | List- | Comprehension- | Alt- | Idiom- | '(' Bracketed- | Constant- | Type- | '()'- | '_|_'- | '_'- | {- External (User-defined) Simple Expression -}- ;--}-simpleExpr :: SyntaxInfo -> IdrisParser PTerm-simpleExpr syn =- {-try (do symbol "!["; t <- term; lchar ']'; return $ PQuote t)- <|>-} do lchar '?'; x <- name; return (PMetavar x)- <|> do lchar '%'; fc <- getFC; reserved "instance"; return (PResolveTC fc)- <|> do reserved "refl"; fc <- getFC;- tm <- option Placeholder (do lchar '{'; t <- expr syn; lchar '}';- return t)- return (PRefl fc tm)- <|> proofExpr syn- <|> tacticsExpr syn- <|> caseExpr syn- <|> try (do fc <- getFC- x <- fnName- return (PRef fc x))- <|> try (listExpr syn)- <|> try (comprehension syn)- <|> try (alt syn)- <|> try (idiom syn)- <|> try (do lchar '('- bracketed (disallowImp syn))- <|> try (do c <- constant- fc <- getFC- return (modifyConst syn fc (PConstant c)))- <|> do reserved "Type"; return PType- <|> try (do symbol "()"- fc <- getFC- return (PTrue fc))- <|> try (do symbol "_|_"- fc <- getFC- return (PFalse fc))- <|> do lchar '_'; return Placeholder- <|> simpleExternalExpr syn- <?> "expression"---{- |Parses the rest of an expression in braces-Bracketed ::=- | Pair- | Expr ')'- | Operator Expr ')'- | Expr Operator ')'- ;--}-bracketed :: SyntaxInfo -> IdrisParser PTerm-bracketed syn =- try (pair syn)- <|> try (do e <- expr syn; lchar ')'; return e)- <|> try (do fc <- getFC; o <- operator; e <- expr syn; lchar ')'- return $ PLam (MN 1000 "ARG") Placeholder- (PApp fc (PRef fc (UN o)) [pexp (PRef fc (MN 1000 "ARG")),- pexp e]))- <|> try (do fc <- getFC; e <- simpleExpr syn; o <- operator; lchar ')'- return $ PLam (MN 1000 "ARG") Placeholder- (PApp fc (PRef fc (UN o)) [pexp e,- pexp (PRef fc (MN 1000 "ARG"))]))- <?> "end of expression in braces"---- bit of a hack here. If the integer doesn't fit in an Int, treat it as a--- big integer, otherwise try fromInteger and the constants as alternatives.--- a better solution would be to fix fromInteger to work with Integer, as the--- name suggests, rather than Int-{-| Finds optimal type for integer constant -}-modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm-modifyConst syn fc (PConstant (BI x))- | not (inPattern syn)- = PAlternative False- (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI (fromInteger x)))]- : consts)- | otherwise = PAlternative False consts- where- consts = [ PConstant (BI x)- , PConstant (I (fromInteger x))- , PConstant (B8 (fromInteger x))- , PConstant (B16 (fromInteger x))- , PConstant (B32 (fromInteger x))- , PConstant (B64 (fromInteger x))- ]-modifyConst syn fc x = x--{- | Parses a list literal expression e.g. [1,2,3]-ListExpr ::=- '[' ExprList? ']'-;--ExprList ::=- Expr- | Expr ',' ExprList- ;-- -}-listExpr :: SyntaxInfo -> IdrisParser PTerm-listExpr syn = do lchar '['; fc <- getFC; xs <- sepBy (expr syn) (lchar ','); lchar ']'- return (mkList fc xs)- <?> "list expression"- where- mkList :: FC -> [PTerm] -> PTerm- mkList fc [] = PRef fc (UN "Nil")- mkList fc (x : xs) = PApp fc (PRef fc (UN "::")) [pexp x, pexp (mkList fc xs)]--{- | Parses rest of pair expression-Pair ::=- Expr RestTuple? ')'- | NTuple ')'- | Name ':' Expr '**' 'Expr' ')'- ;--RestTuple ::=- ',' Expr- | '**' Expr- ;--NTuple ::=- Expr ',' Expr- | Expr ',' NTuple- ;--}-pair :: SyntaxInfo -> IdrisParser PTerm-pair syn = try (do l <- expr syn- fc <- getFC- rest <- restTuple- case rest of- [] -> return l- [Left r] -> return (PPair fc l r)- [Right r] -> return (PDPair fc l Placeholder r))- <|> try (do x <- ntuple- lchar ')'- return x)- <|> do ln <- name; lchar ':'- lty <- expr syn- reservedOp "**"- fc <- getFC- r <- expr syn- lchar ')'- return (PDPair fc (PRef fc ln) lty r)- <?> "pair expression"- where- restTuple :: IdrisParser [Either PTerm PTerm]- restTuple = do lchar ')'; return []- <|> do lchar ','- r <- expr syn- lchar ')'- return [Left r]- <|> do reservedOp "**"- r <- expr syn- lchar ')'- return [Right r]- <?> "end of pair expression"- ntuple :: IdrisParser PTerm- ntuple = try (do l <- expr syn; fc <- getFC; lchar ','- rest <- ntuple- return (PPair fc l rest))- <|> (do l <- expr syn; fc <- getFC; lchar ','- r <- expr syn- return (PPair fc l r))- <?> "tuple expression"--{- | Parses an alternative expression- Alt ::= '(|' Expr_List '|)';-- Expr_List ::=- Expr'- | Expr' ',' Expr_List- ;--}-alt :: SyntaxInfo -> IdrisParser PTerm-alt syn = do symbol "(|"; alts <- sepBy1 (expr' syn) (lchar ','); symbol "|)"- return (PAlternative False alts)--{- | Parses a possibly hidden simple expression-HSimpleExpr ::=- '.' SimpleExpr- | SimpleExpr- ;--}-hsimpleExpr :: SyntaxInfo -> IdrisParser PTerm-hsimpleExpr syn =- do lchar '.'- e <- simpleExpr syn- return $ PHidden e- <|> simpleExpr syn- <?> "expression"--{- | Parses a matching application expression-MatchApp ::=- SimpleExpr '<==' FnName- ;--}-matchApp :: SyntaxInfo -> IdrisParser PTerm-matchApp syn = do ty <- simpleExpr syn- symbol "<=="- fc <- getFC- f <- fnName- return (PLet (MN 0 "match")- ty- (PMatchApp fc f)- (PRef fc (MN 0 "match")))- <?> "matching application expression"--{- | Parses a unification log expression-UnifyLog ::=- '%' 'unifyLog' SimpleExpr- ;--}-unifyLog :: SyntaxInfo -> IdrisParser PTerm-unifyLog syn = do lchar '%'; reserved "unifyLog";- tm <- simpleExpr syn- return (PUnifyLog tm)- <?> "unification log expression"--{- | Parses a function application expression-App ::=- 'mkForeign' Arg Arg*- | SimpleExpr Arg+- ;--}-app :: SyntaxInfo -> IdrisParser PTerm-app syn = do f <- reserved "mkForeign"- fc <- getFC- fn <- arg syn- args <- many (do notEndApp; arg syn)- i <- get- -- mkForeign f args ==>- -- liftPrimIO (\w => mkForeignPrim f args w)- let ap = PApp fc (PRef fc (UN "liftPrimIO"))- [pexp (PLam (MN 0 "w")- Placeholder- (PApp fc (PRef fc (UN "mkForeignPrim"))- (fn : args ++- [pexp (PRef fc (MN 0 "w"))])))]- return (dslify i ap)-- <|> do f <- simpleExpr syn- fc <- getFC- args <- some (do notEndApp; arg syn)- i <- get- return (dslify i $ PApp fc f args)- <?> "function application"- where- dslify :: IState -> PTerm -> PTerm- dslify i (PApp fc (PRef _ f) [a])- | [d] <- lookupCtxt f (idris_dsls i)- = desugar (syn { dsl_info = d }) i (getTm a)- dslify i t = t--{- |Parses a function argument-Arg ::=- ImplicitArg- | ConstraintArg- | SimpleExpr- ;--}-arg :: SyntaxInfo -> IdrisParser PArg-arg syn = try (implicitArg syn)- <|> try (constraintArg syn)- <|> do e <- simpleExpr syn- return (pexp e)- <?> "function argument"--{- |Parses an implicit function argument-ImplicitArg ::=- '{' Name ('=' Expr)? '}'- ;--}-implicitArg :: SyntaxInfo -> IdrisParser PArg-implicitArg syn = do lchar '{'- n <- name- fc <- getFC- v <- option (PRef fc n) (do lchar '='- expr syn)- lchar '}'- return (pimp n v)- <?> "implicit function argument"--{- |Parses a constraint argument (for selecting a named type class instance)-ConstraintArg ::=- '@{' Expr '}'- ;--}-constraintArg :: SyntaxInfo -> IdrisParser PArg-constraintArg syn = do symbol "@{"- e <- expr syn- symbol "}"- return (pconst e)- <?> "constraint argument"---{- |Parses a record field setter expression-RecordType ::=- 'record' '{' FieldTypeList '}';--FieldTypeList ::=- FieldType- | FieldType ',' FieldTypeList- ;--FieldType ::=- FnName '=' Expr- ;--}-recordType :: SyntaxInfo -> IdrisParser PTerm-recordType syn- = do reserved "record"- lchar '{'- fields <- sepBy1 fieldType (lchar ',')- lchar '}'- fc <- getFC- rec <- optional (simpleExpr syn)- case rec of- Nothing ->- return (PLam (MN 0 "fldx") Placeholder- (applyAll fc fields (PRef fc (MN 0 "fldx"))))- Just v -> return (applyAll fc fields v)- <?> "record setting expression"- where fieldType :: IdrisParser (Name, PTerm)- fieldType = do n <- fnName- lchar '='- e <- expr syn- return (n, e)- <?> "field setter"- applyAll :: FC -> [(Name, PTerm)] -> PTerm -> PTerm- applyAll fc [] x = x- applyAll fc ((n, e) : es) x- = applyAll fc es (PApp fc (PRef fc (mkType n)) [pexp e, pexp x])--{- |Creates setters for record types on necessary functions -}-mkType :: Name -> Name-mkType (UN n) = UN ("set_" ++ n)-mkType (MN 0 n) = MN 0 ("set_" ++ n)-mkType (NS n s) = NS (mkType n) s--{- |Parses a type for an expression-TypeSig ::=- ':' Expr- ;--}-typeSig :: SyntaxInfo -> IdrisParser PTerm-typeSig syn = lchar ':' *> typeExpr syn <?> "type"--{- |Parses a type signature-TypeExpr ::= ConstraintList? Expr;- -}-typeExpr :: SyntaxInfo -> IdrisParser PTerm-typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []- sc <- expr syn- return (bindList (PPi constraint) (map (\x -> (MN 0 "c", x)) cs) sc)- <?> "type signature"--{- |Parses a lambda expression-Lambda ::=- '\\' TypeOptDeclList '=>' Expr- | '\\' SimpleExprList '=>' Expr- ;-SimpleExprList ::=- SimpleExpr- | SimpleExpr ',' SimpleExprList- ;--}-lambda :: SyntaxInfo -> IdrisParser PTerm-lambda syn = do lchar '\\'- try (do xt <- tyOptDeclList syn- symbol "=>"- sc <- expr syn- return (bindList PLam xt sc)- <|> (do ps <- sepBy (do fc <- getFC- e <- simpleExpr syn- return (fc, e)) (lchar ',')- symbol "=>"- sc <- expr syn- return (pmList (zip [0..] ps) sc)))- <?> "lambda expression"- where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm- pmList [] sc = sc- pmList ((i, (fc, x)) : xs) sc- = PLam (MN i "lamp") Placeholder- (PCase fc (PRef fc (MN i "lamp"))- [(x, pmList xs sc)])--{- |Parses a term rewrite expression-RewriteTerm ::=- 'rewrite' Expr ('==>' Expr)? 'in' Expr- ;--}-rewriteTerm :: SyntaxInfo -> IdrisParser PTerm-rewriteTerm syn = do reserved "rewrite"- fc <- getFC- prf <- expr syn- giving <- optional (do symbol "==>"; expr' syn)- reserved "in"; sc <- expr syn- return (PRewrite fc- (PApp fc (PRef fc (UN "sym")) [pexp prf]) sc- giving)- <?> "term rewrite expression"--{- |Parses a let binding-Let ::=- 'let' Name TypeSig'? '=' Expr 'in' Expr-| 'let' Expr' '=' Expr' 'in' Expr--TypeSig' ::=- ':' Expr'- ;- -}-let_ :: SyntaxInfo -> IdrisParser PTerm-let_ syn = try (do reserved "let"; n <- name;- ty <- option Placeholder (do lchar ':'; expr' syn)- lchar '='- v <- expr syn- reserved "in"; sc <- expr syn- return (PLet n ty v sc))- <|> (do reserved "let"; fc <- getFC; pat <- expr' (syn { inPattern = True } )- symbol "="; v <- expr syn- reserved "in"; sc <- expr syn- return (PCase fc v [(pat, sc)]))- <?> "let binding"--{- |Parses a quote goal-QuoteGoal ::=- 'quoteGoal' Name 'by' Expr 'in' Expr- ;- -}-quoteGoal :: SyntaxInfo -> IdrisParser PTerm-quoteGoal syn = do reserved "quoteGoal"; n <- name;- reserved "by"- r <- expr syn- reserved "in"- fc <- getFC- sc <- expr syn- return (PGoal fc r n sc)- <?> "quote goal expression"--{- |Parses a dependent type signature-Pi ::=- '|'? Static? '(' TypeDeclList ')' DocComment '->' Expr- | '|'? Static? '{' TypeDeclList '}' '->' Expr- | '{' 'auto' TypeDeclList '}' '->' Expr- | '{' 'default' TypeDeclList '}' '->' Expr- | '{' 'static' '}' Expr' '->' Expr- ;- -}-pi syn =- try (do lazy <- if implicitAllowed syn -- laziness is top level only- then option False (do lchar '|'; return True)- else return False- st <- static- lchar '('; xt <- typeDeclList syn; lchar ')'- doc <- option "" (docComment '^')- symbol "->"- sc <- expr syn- return (bindList (PPi (Exp lazy st doc)) xt sc))- <|> try (if implicitAllowed syn- then do lazy <- option False (do lchar '|'- return True)- st <- static- lchar '{'- xt <- typeDeclList syn- lchar '}'- symbol "->"- sc <- expr syn- return (bindList (PPi (Imp lazy st "")) xt sc)- else fail "no implicit arguments allowed here")- <|> try (do lchar '{'- reserved "auto"- xt <- typeDeclList syn- lchar '}'- symbol "->"- sc <- expr syn- return (bindList (PPi- (TacImp False Dynamic (PTactics [Trivial]) "")) xt sc))- <|> try (do lchar '{'- reserved "default"- script <- simpleExpr syn- xt <- typeDeclList syn- lchar '}'- symbol "->"- sc <- expr syn- return (bindList (PPi (TacImp False Dynamic script "")) xt sc))- <|> do lchar '{'- reserved "static"- lchar '}'- t <- expr' syn- symbol "->"- sc <- expr syn- return (PPi (Exp False Static "") (MN 42 "__pi_arg") t sc)- <?> "dependent type signature"--{- | Parses a type constraint list-ConstraintList ::=- '(' Expr_List ')' '=>'- | Expr '=>'- ;--}-constraintList :: SyntaxInfo -> IdrisParser [PTerm]-constraintList syn = try (do lchar '('- tys <- sepBy1 (expr' (disallowImp syn)) (lchar ',')- lchar ')'- reservedOp "=>"- return tys)- <|> try (do t <- expr (disallowImp syn)- reservedOp "=>"- return [t])- <|> return []- <?> "type constraint list"--{- | Parses a using declaration list-UsingDeclList ::=- UsingDeclList'- | NameList TypeSig- ;--UsingDeclList' ::=- UsingDecl- | UsingDecl ',' UsingDeclList'- ;--NameList ::=- Name- | Name ',' NameList- ;--}-usingDeclList :: SyntaxInfo -> IdrisParser [Using]-usingDeclList syn- = try (sepBy1 (usingDecl syn) (lchar ','))- <|> do ns <- sepBy1 name (lchar ',')- t <- typeSig (disallowImp syn)- return (map (\x -> UImplicit x t) ns)- <?> "using declaration list"--{- |Parses a using declaration-UsingDecl ::=- FnName TypeSig- | FnName FnName+- ;--}-usingDecl :: SyntaxInfo -> IdrisParser Using-usingDecl syn = try (do x <- fnName- t <- typeSig (disallowImp syn)- return (UImplicit x t))- <|> do c <- fnName- xs <- some fnName- return (UConstraint c xs)- <?> "using declaration"--{- |Parses a type declaration list-TypeDeclList ::=- FunctionSignatureList- | NameList TypeSig- ;--FunctionSignatureList ::=- Name TypeSig- | Name TypeSig ',' FunctionSignatureList- ;--}-typeDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]-typeDeclList syn = try (sepBy1 (do x <- fnName- t <- typeSig (disallowImp syn)- return (x,t))- (lchar ','))- <|> do ns <- sepBy1 name (lchar ',')- t <- typeSig (disallowImp syn)- return (map (\x -> (x, t)) ns)- <?> "type declaration list"--{- |Parses a type declaration list with optional parameters-TypeOptDeclList ::=- NameOrPlaceholder TypeSig?- | NameOrPlaceholder TypeSig? ',' TypeOptDeclList- ;--NameOrPlaceHolder ::= Name | '_';--}-tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]-tyOptDeclList syn = sepBy1 (do x <- nameOrPlaceholder- t <- option Placeholder (do lchar ':'- expr syn)- return (x,t))- (lchar ',')- <?> "type declaration list"- where nameOrPlaceholder :: IdrisParser Name- nameOrPlaceholder = fnName- <|> do symbol "_"- return (MN 0 "underscore")- <?> "name or placeholder"--{- |Parses a list comprehension-Comprehension ::= '[' Expr '|' DoList ']';--DoList ::=- Do- | Do ',' DoList- ;--}-comprehension :: SyntaxInfo -> IdrisParser PTerm-comprehension syn- = do lchar '['- fc <- getFC- pat <- expr syn- lchar '|'- qs <- sepBy1 (do_ syn) (lchar ',')- lchar ']'- return (PDoBlock (map addGuard qs ++- [DoExp fc (PApp fc (PRef fc (UN "return"))- [pexp pat])]))- <?> "list comprehension"- where addGuard :: PDo -> PDo- addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc (UN "guard"))- [pexp e])- addGuard x = x--{- |Parses a do-block-Do' ::= Do KeepTerminator;--DoBlock ::=- 'do' OpenBlock Do'+ CloseBlock- ;- -}-doBlock :: SyntaxInfo -> IdrisParser PTerm-doBlock syn- = do reserved "do"- ds <- indentedBlock (do_ syn)- return (PDoBlock ds)- <?> "do block"--{- |Parses an expression inside a do block-Do ::=- 'let' Name TypeSig'? '=' Expr- | 'let' Expr' '=' Expr- | Name '<-' Expr- | Expr' '<-' Expr- | Expr- ;--}-do_ :: SyntaxInfo -> IdrisParser PDo-do_ syn- = try (do reserved "let"- i <- name- ty <- option Placeholder (do lchar ':'- expr' syn)- reservedOp "="- fc <- getFC- e <- expr syn- return (DoLet fc i ty e))- <|> try (do reserved "let"- i <- expr' syn- reservedOp "="- fc <- getFC- sc <- expr syn- return (DoLetP fc i sc))- <|> try (do i <- name- symbol "<-"- fc <- getFC- e <- expr syn;- return (DoBind fc i e))- <|> try (do i <- expr' syn- symbol "<-"- fc <- getFC- e <- expr syn;- return (DoBindP fc i e))- <|> try (do e <- expr syn- fc <- getFC- return (DoExp fc e))- <?> "do block expression"--{- |Parses an expression in idiom brackets-Idiom ::= '[|' Expr '|]';--}-idiom :: SyntaxInfo -> IdrisParser PTerm-idiom syn- = do symbol "[|"- fc <- getFC- e <- expr syn- symbol "|]"- return (PIdiom fc e)- <?> "expression in idiom brackets"--{- |Parses a constant or literal expression-Constant ::=- 'Integer'- | 'Int'- | 'Char'- | 'Float'- | 'String'- | 'Ptr'- | 'Bits8'- | 'Bits16'- | 'Bits32'- | 'Bits64'- | 'Bits8x16'- | 'Bits16x8'- | 'Bits32x4'- | 'Bits64x2'- | Float_t- | Natural_t- | String_t- | Char_t- ;--}-constant :: IdrisParser Core.TT.Const-constant = do reserved "Integer";return (AType (ATInt ITBig))- <|> do reserved "Int"; return (AType (ATInt ITNative))- <|> do reserved "Char"; return (AType (ATInt ITChar))- <|> do reserved "Float"; return (AType ATFloat)- <|> do reserved "String"; return StrType- <|> do reserved "Ptr"; return PtrType- <|> do reserved "Bits8"; return (AType (ATInt (ITFixed IT8)))- <|> do reserved "Bits16"; return (AType (ATInt (ITFixed IT16)))- <|> do reserved "Bits32"; return (AType (ATInt (ITFixed IT32)))- <|> do reserved "Bits64"; return (AType (ATInt (ITFixed IT64)))- <|> do reserved "Bits8x16"; return (AType (ATInt (ITVec IT8 16)))- <|> do reserved "Bits16x8"; return (AType (ATInt (ITVec IT16 8)))- <|> do reserved "Bits32x4"; return (AType (ATInt (ITVec IT32 4)))- <|> do reserved "Bits64x2"; return (AType (ATInt (ITVec IT64 2)))- <|> try (do f <- float; return $ Fl f)- <|> try (do i <- natural; return $ BI i)- <|> try (do s <- stringLiteral; return $ Str s)- <|> try (do c <- charLiteral; return $ Ch c)- <?> "constant or literal"--{- |Parses a static modifier-Static ::=- '[' static ']'-;--}-static :: IdrisParser Static-static = do lchar '['; reserved "static"; lchar ']'; return Static- <|> return Dynamic- <?> "static modifier"--{- |Parses a record type declaration-Record ::=- DocComment Accessibility? 'record' FnName TypeSig 'where' OpenBlock Constructor KeepTerminator CloseBlock;--}-record :: SyntaxInfo -> IdrisParser PDecl-record syn = do doc <- option "" (docComment '|')- acc <- optional accessibility- reserved "record"- fc <- getFC- tyn_in <- fnName- ty <- typeSig (allowImp syn)- let tyn = expandNS syn tyn_in- reserved "where"- (cdoc, cn, cty, _) <- indentedBlockS (constructor syn)- accData acc tyn [cn]- let rsyn = syn { syn_namespace = show (nsroot tyn) :- syn_namespace syn }- let fns = getRecNames rsyn cty- mapM_ (\n -> addAcc n acc) fns- return $ PRecord doc rsyn fc tyn ty cdoc cn cty- <?> "record type declaration"- where- getRecNames :: SyntaxInfo -> PTerm -> [Name]- getRecNames syn (PPi _ n _ sc) = [expandNS syn n, expandNS syn (mkType n)]- ++ getRecNames syn sc- getRecNames _ _ = []-- toFreeze :: Maybe Accessibility -> Maybe Accessibility- toFreeze (Just Frozen) = Just Hidden- toFreeze x = x--{- | Parses data declaration type (normal or codata)-DataI ::= 'data' | 'codata';--}-dataI :: IdrisParser Bool-dataI = do reserved "data"; return False- <|> do reserved "codata"; return True--{- | Parses a data type declaration-Data ::= DocComment? Accessibility? DataI FnName TypeSig ExplicitTypeDataRest?- | DocComment? Accessibility? DataI FnName Name* DataRest?- ;-Constructor' ::= Constructor KeepTerminator;-ExplicitTypeDataRest ::= 'where' OpenBlock Constructor'* CloseBlock;--DataRest ::= '=' SimpleConstructorList Terminator- | 'where'!- ;-SimpleConstructorList ::=- SimpleConstructor- | SimpleConstructor '|' SimpleConstructorList- ;--}-data_ :: SyntaxInfo -> IdrisParser PDecl-data_ syn = try (do doc <- option "" (docComment '|')- acc <- optional accessibility- co <- dataI- fc <- getFC- tyn_in <- fnName- ty <- typeSig (allowImp syn)- let tyn = expandNS syn tyn_in- option (PData doc syn fc co (PLaterdecl tyn ty)) (do- reserved "where"- cons <- indentedBlock (constructor syn)- accData acc tyn (map (\ (_, n, _, _) -> n) cons)- return $ PData doc syn fc co (PDatadecl tyn ty cons)))- <|> try (do doc <- option "" (docComment '|')- pushIndent- acc <- optional accessibility- co <- dataI- fc <- getFC- tyn_in <- fnName- args <- many name- let ty = bindArgs (map (const PType) args) PType- let tyn = expandNS syn tyn_in- option (PData doc syn fc co (PLaterdecl tyn ty)) (do- try (lchar '=') <|> do reserved "where"- let kw = (if co then "co" else "") ++ "data "- let n = show tyn_in ++ " "- let s = kw ++ n- let as = concat (intersperse " " $ map show args) ++ " "- let ns = concat (intersperse " -> " $ map ((\x -> "(" ++ x ++ " : Type)") . show) args)- let ss = concat (intersperse " -> " $ map (const "Type") args)- let fix1 = s ++ as ++ " = ..."- let fix2 = s ++ ": " ++ ns ++ " -> Type where\n ..."- let fix3 = s ++ ": " ++ ss ++ " -> Type where\n ..."- fail $ fixErrorMsg "unexpected \"where\"" [fix1, fix2, fix3]- cons <- sepBy1 (simpleConstructor syn) (lchar '|')- terminator- let conty = mkPApp fc (PRef fc tyn) (map (PRef fc) args)- cons' <- mapM (\ (doc, x, cargs, cfc) ->- do let cty = bindArgs cargs conty- return (doc, x, cty, cfc)) cons- accData acc tyn (map (\ (_, n, _, _) -> n) cons')- return $ PData doc syn fc co (PDatadecl tyn ty cons')))- <?> "data type declaration"- where- mkPApp :: FC -> PTerm -> [PTerm] -> PTerm- mkPApp fc t [] = t- mkPApp fc t xs = PApp fc t (map pexp xs)- bindArgs :: [PTerm] -> PTerm -> PTerm- bindArgs xs t = foldr (PPi expl (MN 0 "t")) t xs---{- | Parses a type constructor declaration- Constructor ::= DocComment? FnName TypeSig;--}-constructor :: SyntaxInfo -> IdrisParser (String, Name, PTerm, FC)-constructor syn- = do doc <- option "" (docComment '|')- cn_in <- fnName; fc <- getFC- let cn = expandNS syn cn_in- ty <- typeSig (allowImp syn)- return (doc, cn, ty, fc)- <?> "constructor"--{- | Parses a constructor for simple discriminative union data types- SimpleConstructor ::= FnName SimpleExpr* DocComment?--}-simpleConstructor :: SyntaxInfo -> IdrisParser (String, Name, [PTerm], FC)-simpleConstructor syn- = do cn_in <- fnName- let cn = expandNS syn cn_in- fc <- getFC- args <- many (do notEndApp- simpleExpr syn)- doc <- option "" (docComment '^')- return (doc, cn, args, fc)- <?> "constructor"--{- | Parses a dsl block declaration-DSL ::= 'dsl' FnName OpenBlock Overload'+ CloseBlock;- -}-dsl :: SyntaxInfo -> IdrisParser PDecl-dsl syn = do reserved "dsl"- n <- fnName- bs <- indentedBlock (overload syn)- let dsl = mkDSL bs (dsl_info syn)- checkDSL dsl- i <- get- put (i { idris_dsls = addDef n dsl (idris_dsls i) })- return (PDSL n dsl)- <?> "dsl block declaration"- where mkDSL :: [(String, PTerm)] -> DSL -> DSL- mkDSL bs dsl = let var = lookup "variable" bs- first = lookup "index_first" bs- next = lookup "index_next" bs- leto = lookup "let" bs- lambda = lookup "lambda" bs in- initDSL { dsl_var = var,- index_first = first,- index_next = next,- dsl_lambda = lambda,- dsl_let = leto }--{- | Checks DSL for errors -}--- FIXME: currently does nothing, check if DSL is really sane-checkDSL :: DSL -> IdrisParser ()-checkDSL dsl = return ()--{- | Parses a DSL overload declaration-OverloadIdentifier ::= 'let' | Identifier;-Overload ::= OverloadIdentifier '=' Expr;--}-overload :: SyntaxInfo -> IdrisParser (String, PTerm)-overload syn = do o <- identifier <|> do reserved "let"- return "let"- if o `notElem` overloadable- then fail $ show o ++ " is not an overloading"- else do- lchar '='- t <- expr syn- return (o, t)- <?> "dsl overload declaratioN"- where overloadable = ["let","lambda","index_first","index_next","variable"]--{- | Parse a clause with patterns-Pattern ::= Clause;--}-pattern :: SyntaxInfo -> IdrisParser PDecl-pattern syn = do fc <- getFC- clause <- clause syn- return (PClauses fc [] (MN 2 "_") [clause]) -- collect together later- <?> "pattern"--{- | Parse a constant applicative form declaration- CAF ::= 'let' FnName '=' Expr Terminator;--}-caf :: SyntaxInfo -> IdrisParser PDecl-caf syn = do reserved "let"- n_in <- fnName; let n = expandNS syn n_in- lchar '='- t <- expr syn- terminator- fc <- getFC- return (PCAF fc n t)- <?> "constant applicative form declaration"--{- | Parse an argument expression- ArgExpr ::= HSimpleExpr | {- In Pattern External (User-defined) Expression -};--}-argExpr :: SyntaxInfo -> IdrisParser PTerm-argExpr syn = let syn' = syn { inPattern = True } in- try (hsimpleExpr syn') <|> simpleExternalExpr syn'- <?> "argument expression"--{- | Parse a right hand side of a function-RHS ::= '=' Expr- | '?=' RHSName? Expr- | 'impossible'- ;--RHSName ::= '{' FnName '}';--}-rhs :: SyntaxInfo -> Name -> IdrisParser PTerm-rhs syn n = do lchar '='; expr syn- <|> do symbol "?=";- name <- option n' (do symbol "{"; n <- fnName; symbol "}";- return n)- r <- expr syn- return (addLet name r)- <|> do reserved "impossible"; return PImpossible- <?> "function right hand side"- where mkN :: Name -> Name- mkN (UN x) = UN (x++"_lemma_1")- mkN (NS x n) = NS (mkN x) n- n' :: Name- n' = mkN n- addLet :: Name -> PTerm -> PTerm- addLet nm (PLet n ty val r) = PLet n ty val (addLet nm r)- addLet nm (PCase fc t cs) = PCase fc t (map addLetC cs)- where addLetC (l, r) = (l, addLet nm r)- addLet nm r = (PLet (UN "value") Placeholder r (PMetavar nm))--{- |Parses a function clause-Clause ::= FnName ConstraintArg* ImplicitOrArgExpr* WExpr* RHS WhereOrTerminator- | SimpleExpr '<==' FnName RHS WhereOrTerminator- | WExpr+ RHS WhereOrTerminator- | FnName ConstraintArg* ImplicitOrArgExpr* WExpr* 'with' SimpleExpr OpenBlock FnDecl+ CloseBlock- | WExpr+ 'with' SimpleExpr OpenBlock FnDecl+ CloseBlock- | ArgExpr Operator ArgExpr WExpr* RHS WhereOrTerminator- | ArgExpr Operator ArgExpr WExpr* 'with' SimpleExpr OpenBlock FnDecl+ CloseBlock- ;-ImplicitOrArgExpr ::= ImplicitArg | ArgExpr;-WhereOrTerminator ::= WhereBlock | Terminator;--}-clause :: SyntaxInfo -> IdrisParser PClause-clause syn- = try (do pushIndent- n_in <- fnName; let n = expandNS syn n_in- cargs <- many (constraintArg syn)- fc <- getFC- args <- many (try (implicitArg (syn { inPattern = True } ))- <|> (fmap pexp (argExpr syn)))- wargs <- many (wExpr syn)- r <- rhs syn n- ist <- get- let ctxt = tt_ctxt ist- let wsyn = syn { syn_namespace = [] }- (wheres, nmap) <- choice [do x <- whereBlock n wsyn- popIndent- return x,- do terminator- return ([], [])]- let capp = PApp fc (PRef fc n)- (cargs ++ args)- ist <- get- put (ist { lastParse = Just n })- return $ PClause fc n capp wargs r wheres)- <|> try (do pushIndent- ty <- simpleExpr syn- symbol "<=="- fc <- getFC- n_in <- fnName; let n = expandNS syn n_in- r <- rhs syn n- ist <- get- let ctxt = tt_ctxt ist- let wsyn = syn { syn_namespace = [] }- (wheres, nmap) <- choice [do x <- whereBlock n wsyn- popIndent- return x,- do terminator- return ([], [])]- let capp = PLet (MN 0 "match")- ty- (PMatchApp fc n)- (PRef fc (MN 0 "match"))- ist <- get- put (ist { lastParse = Just n })- return $ PClause fc n capp [] r wheres)- <|> try (do pushIndent- wargs <- some (wExpr syn)- ist <- get- n <- case lastParse ist of- Just t -> return t- Nothing -> fail "Invalid clause"- fc <- getFC- r <- rhs syn n- let ctxt = tt_ctxt ist- let wsyn = syn { syn_namespace = [] }- (wheres, nmap) <- choice [do x <- whereBlock n wsyn- popIndent- return x,- do terminator- return ([], [])]- return $ PClauseR fc wargs r wheres)-- <|> try (do pushIndent- n_in <- fnName; let n = expandNS syn n_in- cargs <- many (constraintArg syn)- fc <- getFC- args <- many (try (implicitArg (syn { inPattern = True } ))- <|> (fmap pexp (argExpr syn)))- wargs <- many (wExpr syn)- let capp = PApp fc (PRef fc n)- (cargs ++ args)- ist <- get- put (ist { lastParse = Just n })- reserved "with"- wval <- simpleExpr syn- openBlock- ds <- some $ fnDecl syn- let withs = map (fillLHSD n capp wargs) $ concat ds- closeBlock- popIndent- return $ PWith fc n capp wargs wval withs)-- <|> try (do wargs <- some (wExpr syn)- fc <- getFC- reserved "with"- wval <- simpleExpr syn- openBlock- ds <- some $ fnDecl syn- let withs = concat ds- closeBlock- return $ PWithR fc wargs wval withs)-- <|> try(do pushIndent- l <- argExpr syn- op <- operator- let n = expandNS syn (UN op)- r <- argExpr syn- fc <- getFC- wargs <- many (wExpr syn)- rs <- rhs syn n- let wsyn = syn { syn_namespace = [] }- (wheres, nmap) <- choice [do x <- whereBlock n wsyn- popIndent- return x,- do terminator- return ([], [])]- ist <- get- let capp = PApp fc (PRef fc n) [pexp l, pexp r]- put (ist { lastParse = Just n })- return $ PClause fc n capp wargs rs wheres)-- <|> do l <- argExpr syn- op <- operator- let n = expandNS syn (UN op)- r <- argExpr syn- fc <- getFC- wargs <- many (wExpr syn)- reserved "with"- wval <- simpleExpr syn- openBlock- ds <- some $ fnDecl syn- closeBlock- ist <- get- let capp = PApp fc (PRef fc n) [pexp l, pexp r]- let withs = map (fillLHSD n capp wargs) $ concat ds- put (ist { lastParse = Just n })- return $ PWith fc n capp wargs wval withs- <?> "function clause"- where- fillLHS :: Name -> PTerm -> [PTerm] -> PClause -> PClause- fillLHS n capp owargs (PClauseR fc wargs v ws)- = PClause fc n capp (owargs ++ wargs) v ws- fillLHS n capp owargs (PWithR fc wargs v ws)- = PWith fc n capp (owargs ++ wargs) v- (map (fillLHSD n capp (owargs ++ wargs)) ws)- fillLHS _ _ _ c = c-- fillLHSD :: Name -> PTerm -> [PTerm] -> PDecl -> PDecl- fillLHSD n c a (PClauses fc o fn cs) = PClauses fc o fn (map (fillLHS n c a) cs)- fillLHSD n c a x = x--{- |Parses with pattern- WExpr ::= '|' Expr';--}-wExpr :: SyntaxInfo -> IdrisParser PTerm-wExpr syn = do lchar '|'- expr' syn- <?> "with pattern"--{- |Parses a where block-WhereBlock ::= 'where' OpenBlock Decl+ CloseBlock;- -}-whereBlock :: Name -> SyntaxInfo -> IdrisParser ([PDecl], [(Name, Name)])-whereBlock n syn- = do reserved "where"- ds <- indentedBlock1 (decl syn)- let dns = concatMap (concatMap declared) ds- return (concat ds, map (\x -> (x, decoration syn x)) dns)- <?> "where block"--{- |Parses a code generation target language name-Codegen ::= 'C'- | 'Java'- | 'JavaScript'- | 'Node'- | 'LLVM'- | 'Bytecode'- ;--}-codegen_ :: IdrisParser Codegen-codegen_ = try (do reserved "C"; return ViaC)- <|> try (do reserved "Java"; return ViaJava)- <|> try (do reserved "JavaScript"; return ViaJavaScript)- <|> try (do reserved "Node"; return ViaNode)- <|> try (do reserved "LLVM"; return ViaLLVM)- <|> try (do reserved "Bytecode"; return Bytecode)- <?> "code generation language"--{- |Parses a compiler directive-StringList ::=- String- | String ',' StringList- ;--Directive ::= '%' Directive';--Directive' ::= 'lib' CodeGen String_t- | 'link' CodeGen String_t- | 'flag' CodeGen String_t- | 'include' CodeGen String_t- | 'hide' Name- | 'freeze' Name- | 'access' Accessibility- | 'default' Totality- | 'logging' Natural- | 'dynamic' StringList- | 'language' 'TypeProviders'- ;--}-directive :: SyntaxInfo -> IdrisParser [PDecl]-directive syn = try (do lchar '%'; reserved "lib"; cgn <- codegen_; lib <- stringLiteral;- return [PDirective (do addLib cgn lib- addIBC (IBCLib cgn lib))])- <|> try (do lchar '%'; reserved "link"; cgn <- codegen_; obj <- stringLiteral;- return [PDirective (do dirs <- allImportDirs- o <- liftIO $ findInPath dirs obj- addIBC (IBCObj cgn obj) -- just name, search on loading ibc- addObjectFile cgn o)])- <|> try (do lchar '%'; reserved "flag"; cgn <- codegen_;- flag <- stringLiteral- return [PDirective (do addIBC (IBCCGFlag cgn flag)- addFlag cgn flag)])- <|> try (do lchar '%'; reserved "include"; cgn <- codegen_; hdr <- stringLiteral;- return [PDirective (do addHdr cgn hdr- addIBC (IBCHeader cgn hdr))])- <|> try (do lchar '%'; reserved "hide"; n <- iName []- return [PDirective (do setAccessibility n Hidden- addIBC (IBCAccess n Hidden))])- <|> try (do lchar '%'; reserved "freeze"; n <- iName []- return [PDirective (do setAccessibility n Frozen- addIBC (IBCAccess n Frozen))])- <|> try (do lchar '%'; reserved "access"; acc <- accessibility- return [PDirective (do i <- get- put(i { default_access = acc }))])- <|> try (do lchar '%'; reserved "default"; tot <- totality- i <- get- put (i { default_total = tot } )- return [PDirective (do i <- get- put(i { default_total = tot }))])- <|> try (do lchar '%'; reserved "logging"; i <- natural;- return [PDirective (setLogLevel (fromInteger i))])- <|> try (do lchar '%'; reserved "dynamic"; libs <- sepBy1 stringLiteral (lchar ',');- return [PDirective (do added <- addDyLib libs- case added of- Left lib -> addIBC (IBCDyLib (lib_name lib))- Right msg ->- fail $ msg)])- <|> try (do lchar '%'; reserved "language"; ext <- reserved "TypeProviders";- return [PDirective (addLangExt TypeProviders)])- <?> "directive"--{- | Parses a totality-Totality ::= 'partial' | 'total'--}-totality :: IdrisParser Bool-totality- = do reserved "total"; return True- <|> do reserved "partial"; return False--{- | Parses a type provider-Provider ::= '%' 'provide' '(' FnName TypeSig ')' 'with' Expr;- -}-provider :: SyntaxInfo -> IdrisParser [PDecl]-provider syn = do lchar '%'; reserved "provide";- lchar '('; n <- fnName; t <- typeSig syn; lchar ')'- fc <- getFC- reserved "with"- e <- expr syn- return [PProvider syn fc n t e]- <?> "type provider"--{- | Parses a transform-Transform ::= '%' 'transform' Expr '==>' Expr--}-transform :: SyntaxInfo -> IdrisParser [PDecl]-transform syn = do lchar '%'; reserved "transform";- -- leave it unchecked, until we work out what this should- -- actually mean...--- safety <- option True (do reserved "unsafe"--- return False)- l <- expr syn- fc <- getFC- symbol "==>"- r <- expr syn- return [PTransform fc False l r]- <?> "transform"--{- | Parses a tactic script-Tactic ::= 'intro' NameList?- | 'intros'- | 'refine' Name Imp+- | 'mrefine' Name- | 'rewrite' Expr- | 'equiv' Expr- | 'let' Name ':' Expr' '=' Expr- | 'let' Name '=' Expr- | 'focus' Name- | 'exact' Expr- | 'applyTactic' Expr- | 'reflect' Expr- | 'fill' Expr- | 'try' Tactic '|' Tactic- | '{' TacticSeq '}'- | 'compute'- | 'trivial'- | 'solve'- | 'attack'- | 'state'- | 'term'- | 'undo'- | 'qed'- | 'abandon'- | ':' 'q'- ;--Imp ::= '?' | '_';--TacticSeq ::=- Tactic ';' Tactic- | Tactic ';' TacticSeq- ;---}--tactic :: SyntaxInfo -> IdrisParser PTactic-tactic syn = do reserved "intro"; ns <- sepBy name (lchar ',')- return $ Intro ns- <|> do reserved "intros"; return Intros- <|> try (do reserved "refine"; n <- name- imps <- some imp- return $ Refine n imps)- <|> do reserved "refine"; n <- name- i <- get- return $ Refine n []- <|> do reserved "mrefine"; n <- name- i <- get- return $ MatchRefine n- <|> do reserved "rewrite"; t <- expr syn;- i <- get- return $ Rewrite (desugar syn i t)- <|> do reserved "equiv"; t <- expr syn;- i <- get- return $ Equiv (desugar syn i t)- <|> try (do reserved "let"; n <- name; lchar ':';- ty <- expr' syn; lchar '='; t <- expr syn;- i <- get- return $ LetTacTy n (desugar syn i ty) (desugar syn i t))- <|> try (do reserved "let"; n <- name; lchar '=';- t <- expr syn;- i <- get- return $ LetTac n (desugar syn i t))- <|> do reserved "focus"; n <- name- return $ Focus n- <|> do reserved "exact"; t <- expr syn;- i <- get- return $ Exact (desugar syn i t)- <|> do reserved "applyTactic"; t <- expr syn;- i <- get- return $ ApplyTactic (desugar syn i t)- <|> do reserved "reflect"; t <- expr syn;- i <- get- return $ Reflect (desugar syn i t)- <|> do reserved "fill"; t <- expr syn;- i <- get- return $ Fill (desugar syn i t)- <|> do reserved "try"; t <- tactic syn;- lchar '|';- t1 <- tactic syn- return $ Try t t1- <|> do lchar '{'- t <- tactic syn;- lchar ';';- ts <- sepBy1 (tactic syn) (lchar ';')- lchar '}'- return $ TSeq t (mergeSeq ts)- <|> do reserved "compute"; return Compute- <|> do reserved "trivial"; return Trivial- <|> do reserved "solve"; return Solve- <|> do reserved "attack"; return Attack- <|> do reserved "state"; return ProofState- <|> do reserved "term"; return ProofTerm- <|> do reserved "undo"; return Undo- <|> do reserved "qed"; return Qed- <|> do reserved "abandon"; return Abandon- <|> do lchar ':'; reserved "q"; return Abandon- <?> "tactic"- where- imp :: IdrisParser Bool- imp = do lchar '?'; return False- <|> do lchar '_'; return True- mergeSeq :: [PTactic] -> PTactic- mergeSeq [t] = t- mergeSeq (t:ts) = TSeq t (mergeSeq ts)--{- | Parses a tactic as a whole -}-fullTactic :: SyntaxInfo -> IdrisParser PTactic-fullTactic syn = do t <- tactic syn- eof- return t--{- * Loading and parsing -}-{- | Parses an expression from input -}-parseExpr :: IState -> String -> Result PTerm-parseExpr st = parseString (evalStateT (fullExpr defaultSyntax) st) (Directed (UTF8.fromString "(input)") 0 0 0 0)--{- | Parses a tactic from input -}-parseTactic :: IState -> String -> Result PTactic-parseTactic st = parseString (evalStateT (fullTactic defaultSyntax) st) (Directed (UTF8.fromString "(input)") 0 0 0 0)---- | Parse module header and imports-parseImports :: FilePath -> String -> Idris ([String], [String], Maybe Delta)-parseImports fname input- = do i <- getIState- case parseString (evalStateT imports i) (Directed (UTF8.fromString fname) 0 0 0 0) input of- Failure err -> fail (show err)- Success (x, i) -> do -- Discard state updates (there should be- -- none anyway)- return x- where imports :: IdrisParser (([String], [String], Maybe Delta), IState)- imports = do whiteSpace- mname <- moduleHeader- ps <- many import_- mrk <- mark- isEof <- lookAheadMatches eof- let mrk' = if isEof- then Nothing- else Just mrk- i <- get- return ((mname, ps, mrk'), i)----- | A program is a list of declarations, possibly with associated--- documentation strings.-parseProg :: SyntaxInfo -> FilePath -> String -> Maybe Delta ->- Idris [PDecl]-parseProg syn fname input mrk- = do i <- getIState- case parseString (evalStateT mainProg i) (Directed (UTF8.fromString fname) 0 0 0 0) input of- Failure doc -> do iputStrLn (show doc)- -- FIXME: Get error location from trifecta- --let errl = sourceLine (errorPos err)- i <- getIState- putIState (i { errLine = Just 0 }) -- Just errl })- return []- Success (x, i) -> do putIState i- return $ collect x- where mainProg :: IdrisParser ([PDecl], IState)- mainProg = case mrk of- Nothing -> do i <- get; return ([], i)- Just mrk -> do- release mrk- ds <- prog syn- i' <- get- return (ds, i')---- | Collect 'PClauses' with the same function name-collect :: [PDecl] -> [PDecl]-collect (c@(PClauses _ o _ _) : ds)- = clauses (cname c) [] (c : ds)- where clauses :: Maybe Name -> [PClause] -> [PDecl] -> [PDecl]- clauses j@(Just n) acc (PClauses fc _ _ [PClause fc' n' l ws r w] : ds)- | n == n' = clauses j (PClause fc' n' l ws r (collect w) : acc) ds- clauses j@(Just n) acc (PClauses fc _ _ [PWith fc' n' l ws r w] : ds)- | n == n' = clauses j (PWith fc' n' l ws r (collect w) : acc) ds- clauses (Just n) acc xs = PClauses (fcOf c) o n (reverse acc) : collect xs- clauses Nothing acc (x:xs) = collect xs- clauses Nothing acc [] = []-- cname :: PDecl -> Maybe Name- cname (PClauses fc _ _ [PClause _ n _ _ _ _]) = Just n- cname (PClauses fc _ _ [PWith _ n _ _ _ _]) = Just n- cname (PClauses fc _ _ [PClauseR _ _ _ _]) = Nothing- cname (PClauses fc _ _ [PWithR _ _ _ _]) = Nothing- fcOf :: PDecl -> FC- fcOf (PClauses fc _ _ _) = fc-collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds-collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds-collect (PNamespace ns ps : ds) = PNamespace ns (collect ps) : collect ds-collect (PClass doc f s cs n ps ds : ds') - = PClass doc f s cs n ps (collect ds) : collect ds'-collect (PInstance f s cs n ps t en ds : ds') - = PInstance f s cs n ps t en (collect ds) : collect ds'-collect (d : ds) = d : collect ds-collect [] = []--{- | Load idris module -}-loadModule :: FilePath -> Idris String-loadModule f- = idrisCatch (do i <- getIState- let file = takeWhile (/= ' ') f- ibcsd <- valIBCSubDir i- ids <- allImportDirs- fp <- liftIO $ findImport ids ibcsd file- if file `elem` imported i- then iLOG $ "Already read " ++ file- else do putIState (i { imported = file : imported i })- case fp of- IDR fn -> loadSource False fn- LIDR fn -> loadSource True fn- IBC fn src ->- idrisCatch (loadIBC fn)- (\c -> do iLOG $ fn ++ " failed " ++ show c- case src of- IDR sfn -> loadSource False sfn- LIDR sfn -> loadSource True sfn)- let (dir, fh) = splitFileName file- return (dropExtension fh))- (\e -> do let msg = show e- setErrLine (getErrLine msg)- iputStrLn msg- return "")--{- | Load idris code from file -}-loadFromIFile :: IFileType -> Idris ()-loadFromIFile i@(IBC fn src)- = do iLOG $ "Skipping " ++ getSrcFile i- idrisCatch (loadIBC fn)- (\c -> do fail $ fn ++ " failed " ++ show c)- where- getSrcFile (IDR fn) = fn- getSrcFile (LIDR fn) = fn- getSrcFile (IBC f src) = getSrcFile src--loadFromIFile (IDR fn) = loadSource' False fn-loadFromIFile (LIDR fn) = loadSource' True fn--{-| Load idris source code and show error if something wrong happens -}-loadSource' :: Bool -> FilePath -> Idris ()-loadSource' lidr r- = idrisCatch (loadSource lidr r)- (\e -> do let msg = show e- setErrLine (getErrLine msg)- iputStrLn msg)--{- | Load Idris source code-}-loadSource :: Bool -> FilePath -> Idris ()-loadSource lidr f- = do iLOG ("Reading " ++ f)- i <- getIState- let def_total = default_total i- file_in <- liftIO $ readFile f- file <- if lidr then tclift $ unlit f file_in else return file_in- (mname, modules, pos) <- parseImports f file- i <- getIState- putIState (i { default_access = Hidden })- clearIBC -- start a new .ibc file- mapM_ (addIBC . IBCImport) modules- ds' <- parseProg (defaultSyntax {syn_namespace = reverse mname })- f file pos- unless (null ds') $ do- let ds = namespaces mname ds'- logLvl 3 (dumpDecls ds)- i <- getIState- logLvl 10 (show (toAlist (idris_implicits i)))- logLvl 3 (show (idris_infixes i))- -- Now add all the declarations to the context- v <- verbose- when v $ iputStrLn $ "Type checking " ++ f- -- we totality check after every Mutual block, so if- -- anything is a single definition, wrap it in a- -- mutual block on its own- elabDecls toplevel (map toMutual ds)- i <- getIState- -- simplify every definition do give the totality checker- -- a better chance- mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n- updateContext (simplifyCasedef n))- (map snd (idris_totcheck i))- -- build size change graph from simplified definitions- iLOG "Totality checking"- i <- getIState- mapM_ buildSCG (idris_totcheck i)- mapM_ checkDeclTotality (idris_totcheck i)- iLOG ("Finished " ++ f)- ibcsd <- valIBCSubDir i- iLOG "Universe checking"- iucheck- let ibc = ibcPathNoFallback ibcsd f- i <- getIState- addHides (hide_list i)- ok <- noErrors- when ok $- idrisCatch (do writeIBC f ibc; clearIBC)- (\c -> return ()) -- failure is harmless- i <- getIState- putIState (i { default_total = def_total,- hide_list = [] })- return ()- return ()- where- namespaces :: [String] -> [PDecl] -> [PDecl]- namespaces [] ds = ds- namespaces (x:xs) ds = [PNamespace x (namespaces xs ds)]-- toMutual :: PDecl -> PDecl- toMutual m@(PMutual _ d) = m- toMutual x = let r = PMutual (FC "single mutual" 0) [x] in- case x of- PClauses _ _ _ _ -> r- PClass _ _ _ _ _ _ _ -> r- PInstance _ _ _ _ _ _ _ _ -> r- _ -> x--{- | Adds names to hide list -}-addHides :: [(Name, Maybe Accessibility)] -> Idris ()-addHides xs = do i <- getIState- let defh = default_access i- let (hs, as) = partition isNothing xs- unless (null as) $- mapM_ doHide- (map (\ (n, _) -> (n, defh)) hs ++- map (\ (n, Just a) -> (n, a)) as)- where isNothing (_, Nothing) = True- isNothing _ = False-- doHide (n, a) = do setAccessibility n a- addIBC (IBCAccess n a)-+module Idris.Parser(module Idris.Parser, + module Idris.ParseExpr,+ module Idris.ParseData,+ module Idris.ParseHelpers,+ module Idris.ParseOps) where++import Prelude hiding (pi)++import Text.Trifecta.Delta+import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)+import Text.Parser.LookAhead+import Text.Parser.Expression+import qualified Text.Parser.Token as Tok+import qualified Text.Parser.Char as Chr+import qualified Text.Parser.Token.Highlight as Hi++import Idris.AbsSyntax+import Idris.DSL+import Idris.Imports+import Idris.Error+import Idris.ElabDecls+import Idris.ElabTerm hiding (namespace, params)+import Idris.Coverage+import Idris.IBC+import Idris.Unlit+import Idris.Providers++import Idris.ParseHelpers+import Idris.ParseOps+import Idris.ParseExpr+import Idris.ParseData++import Paths_idris++import Util.DynamicLinker++import Core.TT+import Core.Evaluate++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict++import Data.Maybe+import qualified Data.List.Split as Spl+import Data.List+import Data.Monoid+import Data.Char+import qualified Data.HashSet as HS+import qualified Data.Text as T+import qualified Data.ByteString.UTF8 as UTF8++import Debug.Trace++import System.FilePath+{-+ grammar shortcut notation:+ ~CHARSEQ = complement of char sequence (i.e. any character except CHARSEQ)+ RULE? = optional rule (i.e. RULE or nothing)+ RULE* = repeated rule (i.e. RULE zero or more times)+ RULE+ = repeated rule with at least one match (i.e. RULE one or more times)+ RULE! = invalid rule (i.e. rule that is not valid in context, report meaningful error in case)+ RULE{n} = rule repeated n times+-}++{- * Main grammar -}++{- | Parses module definition+ ModuleHeader ::= 'module' Identifier_t ';'?;+-}+moduleHeader :: IdrisParser [String]+moduleHeader = try (do reserved "module"+ i <- identifier+ option ';' (lchar ';')+ return (moduleName i))+ <|> return []+ where moduleName x = case span (/='.') x of+ (x, "") -> [x]+ (x, '.':y) -> x : moduleName y++{- | Parses an import statement+ Import ::= 'import' Identifier_t ';'?;+ -}+import_ :: IdrisParser String+import_ = do reserved "import"+ id <- identifier+ option ';' (lchar ';')+ return (toPath id)+ <?> "import statement"+ where toPath f = foldl1' (</>) (Spl.splitOn "." f)++{- | Parses program source+ Prog ::= Decl* EOF;+ -}+prog :: SyntaxInfo -> IdrisParser [PDecl]+prog syn = do whiteSpace+ decls <- many (decl syn)+ notOpenBraces+ eof+ let c = (concat decls)+ return c++{- | Parses a top-level declaration+Decl ::=+ Decl'+ | Using+ | Params+ | Mutual+ | Namespace+ | Class+ | Instance+ | DSL+ | Directive+ | Provider+ | Transform+ | Import!+ ;+-}+decl :: SyntaxInfo -> IdrisParser [PDecl]+decl syn = do notEndBlock+ declBody+ where declBody :: IdrisParser [PDecl]+ declBody = declBody'+ <|> using_ syn+ <|> params syn+ <|> mutual syn+ <|> namespace syn+ <|> class_ syn+ <|> instance_ syn+ <|> do d <- dsl syn; return [d]+ <|> directive syn+ <|> provider syn+ <|> transform syn+ <|> do import_; fail "imports must be at top of file"+ <?> "declaration"+ declBody' :: IdrisParser [PDecl]+ declBody' = do d <- decl' syn+ i <- get+ let d' = fmap (desugar syn i) d+ return [d']++{- | Parses a top-level declaration with possible syntax sugar+Decl' ::=+ Fixity+ | FunDecl'+ | Data+ | Record+ | SyntaxDecl+ ;+-}+decl' :: SyntaxInfo -> IdrisParser PDecl+decl' syn = fixity+ <|> syntaxDecl syn+ <|> fnDecl' syn+ <|> data_ syn+ <|> record syn+ <?> "declaration"++{- | Parses a syntax extension declaration (and adds the rule to parser state)+ SyntaxDecl ::= SyntaxRule;+-}+syntaxDecl :: SyntaxInfo -> IdrisParser PDecl+syntaxDecl syn = do s <- syntaxRule syn+ i <- get+ let rs = syntax_rules i+ let ns = syntax_keywords i+ let ibc = ibc_write i+ let ks = map show (names s)+ put (i { syntax_rules = s : rs,+ syntax_keywords = ks ++ ns,+ ibc_write = IBCSyntax s : map IBCKeyword ks ++ ibc })+ fc <- getFC+ return (PSyntax fc s)+ where names (Rule syms _ _) = mapMaybe ename syms+ ename (Keyword n) = Just n+ ename _ = Nothing++{- | Parses a syntax extension declaration+SyntaxRuleOpts ::= 'term' | 'pattern';++SyntaxRule ::=+ SyntaxRuleOpts? 'syntax' SyntaxSym+ '=' TypeExpr Terminator;++SyntaxSym ::= '[' Name_t ']'+ | '{' Name_t '}'+ | Name_t+ | StringLiteral_t+ ;+-}+syntaxRule :: SyntaxInfo -> IdrisParser Syntax+syntaxRule syn+ = do sty <- try (do+ pushIndent+ sty <- option AnySyntax (do reserved "term"; return TermSyntax+ <|> do reserved "pattern"; return PatternSyntax)+ reserved "syntax"+ return sty)+ syms <- some syntaxSym+ when (all isExpr syms) $ unexpected "missing keywords in syntax rule"+ let ns = mapMaybe getName syms+ when (length ns /= length (nub ns))+ $ unexpected "repeated variable in syntax rule"+ lchar '='+ tm <- typeExpr (allowImp syn)+ terminator+ return (Rule (mkSimple syms) tm sty)+ where+ isExpr (Expr _) = True+ isExpr _ = False+ getName (Expr n) = Just n+ getName _ = Nothing+ -- Can't parse two full expressions (i.e. expressions with application) in a row+ -- so change them both to a simple expression+ mkSimple (Expr e : es) = SimpleExpr e : mkSimple' es+ mkSimple xs = mkSimple' xs++ mkSimple' (Expr e : Expr e1 : es) = SimpleExpr e : SimpleExpr e1 :+ mkSimple es+ mkSimple' (e : es) = e : mkSimple' es+ mkSimple' [] = []+++{- | Parses a syntax symbol (either binding variable, keyword or expression)+SyntaxSym ::= '[' Name_t ']'+ | '{' Name_t '}'+ | Name_t+ | StringLiteral_t+ ;+ -}+syntaxSym :: IdrisParser SSymbol+syntaxSym = try (do lchar '['; n <- name; lchar ']'+ return (Expr n))+ <|> try (do lchar '{'; n <- name; lchar '}'+ return (Binding n))+ <|> do n <- iName []+ return (Keyword n)+ <|> do sym <- stringLiteral+ return (Symbol sym)+ <?> "syntax symbol"++{- | Parses a function declaration with possible syntax sugar+ FunDecl ::= FunDecl';+-}+fnDecl :: SyntaxInfo -> IdrisParser [PDecl]+fnDecl syn+ = try (do notEndBlock+ d <- fnDecl' syn+ i <- get+ let d' = fmap (desugar syn i) d+ return [d'])+ <?> "function declaration"++{- Parses a function declaration+ FunDecl' ::=+ DocComment_t? FnOpts* Accessibility? FnOpts* FnName TypeSig Terminator+ | Postulate+ | Pattern+ | CAF+ ;+-}+fnDecl' :: SyntaxInfo -> IdrisParser PDecl+fnDecl' syn = do (doc, fc, opts', n, acc) <- try (do + doc <- option "" (docComment '|')+ pushIndent+ ist <- get+ let initOpts = if default_total ist+ then [TotalFn]+ else []+ opts <- fnOpts initOpts+ acc <- optional accessibility+ opts' <- fnOpts opts+ n_in <- fnName+ let n = expandNS syn n_in+ fc <- getFC+ lchar ':'+ return (doc, fc, opts', n, acc))+ ty <- typeExpr (allowImp syn)+ terminator+ addAcc n acc+ return (PTy doc syn fc opts' n ty)+ <|> postulate syn+ <|> caf syn+ <|> pattern syn+ <?> "function declaration"+++{- Parses function options given initial options+FnOpts ::= 'total'+ | 'partial'+ | 'implicit'+ | '%' 'assert_total'+ | '%' 'reflection'+ | '%' 'specialise' '[' NameTimesList? ']'+ ;++NameTimes ::= FnName Natural?;++NameTimesList ::=+ NameTimes+ | NameTimes ',' NameTimesList+ ;++-}+-- FIXME: Check compatability for function options (i.e. partal/total)+fnOpts :: [FnOpt] -> IdrisParser [FnOpt]+fnOpts opts+ = do reserved "total"; fnOpts (TotalFn : opts)+ <|> do reserved "partial"; fnOpts (PartialFn : (opts \\ [TotalFn]))+ <|> do try (lchar '%' *> reserved "export"); c <- stringLiteral;+ fnOpts (CExport c : opts)+ <|> do try (lchar '%' *> reserved "assert_total");+ fnOpts (AssertTotal : opts)+ <|> do try (lchar '%' *> reserved "reflection");+ fnOpts (Reflection : opts)+ <|> do lchar '%'; reserved "specialise";+ lchar '['; ns <- sepBy nameTimes (lchar ','); lchar ']'+ fnOpts (Specialise ns : opts)+ <|> do reserved "implicit"; fnOpts (Implicit : opts)+ <|> return opts+ <?> "function modifier"+ where nameTimes :: IdrisParser (Name, Maybe Int)+ nameTimes = do n <- fnName+ t <- option Nothing (do reds <- natural+ return (Just (fromInteger reds)))+ return (n, t)++{- | Parses a postulate++Postulate ::=+ DocComment_t? 'postulate' FnOpts* Accesibility? FnOpts* FnName TypeSig Terminator+ ;+-}+postulate :: SyntaxInfo -> IdrisParser PDecl+postulate syn = do doc <- try $ do doc <- option "" (docComment '|')+ pushIndent+ reserved "postulate"+ return doc+ ist <- get+ let initOpts = if default_total ist+ then [TotalFn]+ else []+ opts <- fnOpts initOpts+ acc <- optional accessibility+ opts' <- fnOpts opts+ n_in <- fnName+ let n = expandNS syn n_in+ lchar ':'+ ty <- typeExpr (allowImp syn)+ fc <- getFC+ terminator+ addAcc n acc+ return (PPostulate doc syn fc opts' n ty)+ <?> "postulate"++{- | Parses a using declaration++Using ::=+ 'using' '(' UsingDeclList ')' OpenBlock Decl* CloseBlock+ ;+ -}+using_ :: SyntaxInfo -> IdrisParser [PDecl]+using_ syn =+ do reserved "using"; lchar '('; ns <- usingDeclList syn; lchar ')'+ openBlock+ let uvars = using syn+ ds <- many (decl (syn { using = uvars ++ ns }))+ closeBlock+ return (concat ds)+ <?> "using declaration"++{- | Parses a parameters declaration++Params ::=+ 'parameters' '(' TypeDeclList ')' OpenBlock Decl* CloseBlock+ ;+ -}+params :: SyntaxInfo -> IdrisParser [PDecl]+params syn =+ do reserved "parameters"; lchar '('; ns <- typeDeclList syn; lchar ')'+ openBlock+ let pvars = syn_params syn+ ds <- many (decl syn { syn_params = pvars ++ ns })+ closeBlock+ fc <- getFC+ return [PParams fc ns (concat ds)]+ <?> "parameters declaration"++{- | Parses a mutual declaration (for mutually recursive functions)++Mutual ::=+ 'mutual' OpenBlock Decl* CloseBlock+ ;+-}+mutual :: SyntaxInfo -> IdrisParser [PDecl]+mutual syn =+ do reserved "mutual"+ openBlock+ let pvars = syn_params syn+ ds <- many (decl syn)+ closeBlock+ fc <- getFC+ return [PMutual fc (concat ds)]+ <?> "mutual block"++{- | Parses a namespace declaration++Namespace ::=+ 'namespace' identifier OpenBlock Decl+ CloseBlock+ ;+-}+namespace :: SyntaxInfo -> IdrisParser [PDecl]+namespace syn =+ do reserved "namespace"; n <- identifier;+ openBlock+ ds <- some (decl syn { syn_namespace = n : syn_namespace syn })+ closeBlock+ return [PNamespace n (concat ds)]+ <?> "namespace declaration"++{- |Parses a methods block (for type classes and instances)+ MethodsBlock ::= 'where' OpenBlock FnDecl* CloseBlock+ -}+methodsBlock :: SyntaxInfo -> IdrisParser [PDecl]+methodsBlock syn = do reserved "where"+ openBlock+ ds <- many (fnDecl syn)+ closeBlock+ return (concat ds)+ <?> "methods block"++{- |Parses a type class declaration++ClassArgument ::=+ Name+ | '(' Name ':' Expr ')'+ ;++Class ::=+ DocComment_t? Accessibility? 'class' ConstraintList? Name ClassArgument* MethodsBlock?+ ;+-}+class_ :: SyntaxInfo -> IdrisParser [PDecl]+class_ syn = do (doc, acc) <- try (do + doc <- option "" (docComment '|')+ acc <- optional accessibility+ return (doc, acc))+ reserved "class"; fc <- getFC; cons <- constraintList syn; n_in <- name+ let n = expandNS syn n_in+ cs <- many carg+ ds <- option [] (methodsBlock syn)+ accData acc n (concatMap declared ds)+ return [PClass doc syn fc cons n cs ds]+ <?> "type-class declaration"+ where+ carg :: IdrisParser (Name, PTerm)+ carg = do lchar '('; i <- name; lchar ':'; ty <- expr syn; lchar ')'+ return (i, ty)+ <|> do i <- name;+ return (i, PType)++{- |Parses a type class instance declaration++ Instance ::=+ 'instance' InstanceName? ConstraintList? Name SimpleExpr* MethodsBlock?+ ;++ InstanceName ::= '[' Name ']';+-}+instance_ :: SyntaxInfo -> IdrisParser [PDecl]+instance_ syn = do reserved "instance"; fc <- getFC+ en <- optional instanceName+ cs <- constraintList syn+ cn <- name+ args <- many (simpleExpr syn)+ let sc = PApp fc (PRef fc cn) (map pexp args)+ let t = bindList (PPi constraint) (map (\x -> (MN 0 "c", x)) cs) sc+ ds <- option [] (methodsBlock syn)+ return [PInstance syn fc cs cn args t en ds]+ <?> "instance declaratioN"+ where instanceName :: IdrisParser Name+ instanceName = do lchar '['; n_in <- fnName; lchar ']'+ let n = expandNS syn n_in+ return n+ <?> "instance name"+++{- | Parses a using declaration list+UsingDeclList ::=+ UsingDeclList'+ | NameList TypeSig+ ;++UsingDeclList' ::=+ UsingDecl+ | UsingDecl ',' UsingDeclList'+ ;++NameList ::=+ Name+ | Name ',' NameList+ ;+-}+usingDeclList :: SyntaxInfo -> IdrisParser [Using]+usingDeclList syn+ = try (sepBy1 (usingDecl syn) (lchar ','))+ <|> do ns <- sepBy1 name (lchar ',')+ lchar ':'+ t <- typeExpr (disallowImp syn)+ return (map (\x -> UImplicit x t) ns)+ <?> "using declaration list"++{- |Parses a using declaration+UsingDecl ::=+ FnName TypeSig+ | FnName FnName++ ;+-}+usingDecl :: SyntaxInfo -> IdrisParser Using+usingDecl syn = try (do x <- fnName+ lchar ':'+ t <- typeExpr (disallowImp syn)+ return (UImplicit x t))+ <|> do c <- fnName+ xs <- some fnName+ return (UConstraint c xs)+ <?> "using declaration"++{- | Parse a clause with patterns+Pattern ::= Clause;+-}+pattern :: SyntaxInfo -> IdrisParser PDecl+pattern syn = do fc <- getFC+ clause <- clause syn+ return (PClauses fc [] (MN 2 "_") [clause]) -- collect together later+ <?> "pattern"++{- | Parse a constant applicative form declaration+ CAF ::= 'let' FnName '=' Expr Terminator;+-}+caf :: SyntaxInfo -> IdrisParser PDecl+caf syn = do reserved "let"+ n_in <- fnName; let n = expandNS syn n_in+ lchar '='+ t <- expr syn+ terminator+ fc <- getFC+ return (PCAF fc n t)+ <?> "constant applicative form declaration"++{- | Parse an argument expression+ ArgExpr ::= HSimpleExpr | {- In Pattern External (User-defined) Expression -};+-}+argExpr :: SyntaxInfo -> IdrisParser PTerm+argExpr syn = let syn' = syn { inPattern = True } in+ try (hsimpleExpr syn') <|> simpleExternalExpr syn'+ <?> "argument expression"++{- | Parse a right hand side of a function+RHS ::= '=' Expr+ | '?=' RHSName? Expr+ | 'impossible'+ ;++RHSName ::= '{' FnName '}';+-}+rhs :: SyntaxInfo -> Name -> IdrisParser PTerm+rhs syn n = do lchar '='; expr syn+ <|> do symbol "?=";+ name <- option n' (do symbol "{"; n <- fnName; symbol "}";+ return n)+ r <- expr syn+ return (addLet name r)+ <|> do reserved "impossible"; return PImpossible+ <?> "function right hand side"+ where mkN :: Name -> Name+ mkN (UN x) = UN (x++"_lemma_1")+ mkN (NS x n) = NS (mkN x) n+ n' :: Name+ n' = mkN n+ addLet :: Name -> PTerm -> PTerm+ addLet nm (PLet n ty val r) = PLet n ty val (addLet nm r)+ addLet nm (PCase fc t cs) = PCase fc t (map addLetC cs)+ where addLetC (l, r) = (l, addLet nm r)+ addLet nm r = (PLet (UN "value") Placeholder r (PMetavar nm))++{- |Parses a function clause+RHSOrWithBlock ::= RHS WhereOrTerminator+ | 'with' SimpleExpr OpenBlock FnDecl+ CloseBlock+ ;+Clause ::= WExpr+ RHSOrWithBlock+ | SimpleExpr '<==' FnName RHS WhereOrTerminator+ | ArgExpr Operator ArgExpr WExpr* RHSOrWithBlock {- Except "=" and "?=" operators to avoid ambiguity -}+ | FnName ConstraintArg* ImplicitOrArgExpr* WExpr* RHSOrWithBlock+ ;+ImplicitOrArgExpr ::= ImplicitArg | ArgExpr;+WhereOrTerminator ::= WhereBlock | Terminator;+-}+clause :: SyntaxInfo -> IdrisParser PClause+clause syn+ = do wargs <- try (do pushIndent; some (wExpr syn))+ fc <- getFC+ ist <- get+ n <- case lastParse ist of+ Just t -> return t+ Nothing -> fail "Invalid clause"+ (do r <- rhs syn n+ let ctxt = tt_ctxt ist+ let wsyn = syn { syn_namespace = [] }+ (wheres, nmap) <- choice [do x <- whereBlock n wsyn+ popIndent+ return x,+ do terminator+ return ([], [])]+ return $ PClauseR fc wargs r wheres) <|> (do+ popIndent+ reserved "with"+ wval <- simpleExpr syn+ openBlock+ ds <- some $ fnDecl syn+ let withs = concat ds+ closeBlock+ return $ PWithR fc wargs wval withs)+ <|> do ty <- try (do pushIndent+ ty <- simpleExpr syn+ symbol "<=="+ return ty)+ fc <- getFC+ n_in <- fnName; let n = expandNS syn n_in+ r <- rhs syn n+ ist <- get+ let ctxt = tt_ctxt ist+ let wsyn = syn { syn_namespace = [] }+ (wheres, nmap) <- choice [do x <- whereBlock n wsyn+ popIndent+ return x,+ do terminator+ return ([], [])]+ let capp = PLet (MN 0 "match")+ ty+ (PMatchApp fc n)+ (PRef fc (MN 0 "match"))+ ist <- get+ put (ist { lastParse = Just n })+ return $ PClause fc n capp [] r wheres+ <|> do (l, op) <- try (do + pushIndent+ l <- argExpr syn+ op <- operator+ when (op == "=" || op == "?=" ) (fail "infix clause definition with \"=\" and \"?=\" not supported ")+ return (l, op))+ let n = expandNS syn (UN op)+ r <- argExpr syn+ fc <- getFC+ wargs <- many (wExpr syn)+ (do rs <- rhs syn n+ let wsyn = syn { syn_namespace = [] }+ (wheres, nmap) <- choice [do x <- whereBlock n wsyn+ popIndent+ return x,+ do terminator+ return ([], [])]+ ist <- get+ let capp = PApp fc (PRef fc n) [pexp l, pexp r]+ put (ist { lastParse = Just n })+ return $ PClause fc n capp wargs rs wheres) <|> (do+ popIndent+ reserved "with"+ lchar '(' <?> "parenthesized expression"+ wval <- bracketed syn+ openBlock+ ds <- some $ fnDecl syn+ closeBlock+ ist <- get+ let capp = PApp fc (PRef fc n) [pexp l, pexp r]+ let withs = map (fillLHSD n capp wargs) $ concat ds+ put (ist { lastParse = Just n })+ return $ PWith fc n capp wargs wval withs)+ <|> do pushIndent+ n_in <- fnName; let n = expandNS syn n_in+ cargs <- many (constraintArg syn)+ fc <- getFC+ args <- many (try (implicitArg (syn { inPattern = True } ))+ <|> (fmap pexp (argExpr syn)))+ wargs <- many (wExpr syn)+ let capp = PApp fc (PRef fc n)+ (cargs ++ args)+ (do r <- rhs syn n+ ist <- get+ let ctxt = tt_ctxt ist+ let wsyn = syn { syn_namespace = [] }+ (wheres, nmap) <- choice [do x <- whereBlock n wsyn+ popIndent+ return x,+ do terminator+ return ([], [])]+ ist <- get+ put (ist { lastParse = Just n })+ return $ PClause fc n capp wargs r wheres) <|> (do+ reserved "with"+ ist <- get+ put (ist { lastParse = Just n })+ lchar '(' <?> "parenthesized expression"+ wval <- bracketed syn+ openBlock+ ds <- some $ fnDecl syn+ let withs = map (fillLHSD n capp wargs) $ concat ds+ closeBlock+ popIndent+ return $ PWith fc n capp wargs wval withs)+ <?> "function clause"+ where+ fillLHS :: Name -> PTerm -> [PTerm] -> PClause -> PClause+ fillLHS n capp owargs (PClauseR fc wargs v ws)+ = PClause fc n capp (owargs ++ wargs) v ws+ fillLHS n capp owargs (PWithR fc wargs v ws)+ = PWith fc n capp (owargs ++ wargs) v+ (map (fillLHSD n capp (owargs ++ wargs)) ws)+ fillLHS _ _ _ c = c++ fillLHSD :: Name -> PTerm -> [PTerm] -> PDecl -> PDecl+ fillLHSD n c a (PClauses fc o fn cs) = PClauses fc o fn (map (fillLHS n c a) cs)+ fillLHSD n c a x = x++{- |Parses with pattern+ WExpr ::= '|' Expr';+-}+wExpr :: SyntaxInfo -> IdrisParser PTerm+wExpr syn = do lchar '|'+ expr' syn+ <?> "with pattern"++{- |Parses a where block+WhereBlock ::= 'where' OpenBlock Decl+ CloseBlock;+ -}+whereBlock :: Name -> SyntaxInfo -> IdrisParser ([PDecl], [(Name, Name)])+whereBlock n syn+ = do reserved "where"+ ds <- indentedBlock1 (decl syn)+ let dns = concatMap (concatMap declared) ds+ return (concat ds, map (\x -> (x, decoration syn x)) dns)+ <?> "where block"++{- |Parses a code generation target language name+Codegen ::= 'C'+ | 'Java'+ | 'JavaScript'+ | 'Node'+ | 'LLVM'+ | 'Bytecode'+ ;+-}+codegen_ :: IdrisParser Codegen+codegen_ = do reserved "C"; return ViaC+ <|> do reserved "Java"; return ViaJava+ <|> do reserved "JavaScript"; return ViaJavaScript+ <|> do reserved "Node"; return ViaNode+ <|> do reserved "LLVM"; return ViaLLVM+ <|> do reserved "Bytecode"; return Bytecode+ <?> "code generation language"++{- |Parses a compiler directive+StringList ::=+ String+ | String ',' StringList+ ;++Directive ::= '%' Directive';++Directive' ::= 'lib' CodeGen String_t+ | 'link' CodeGen String_t+ | 'flag' CodeGen String_t+ | 'include' CodeGen String_t+ | 'hide' Name+ | 'freeze' Name+ | 'access' Accessibility+ | 'default' Totality+ | 'logging' Natural+ | 'dynamic' StringList+ | 'language' 'TypeProviders'+ | 'language' 'ErrorReflection'+ ;+-}+directive :: SyntaxInfo -> IdrisParser [PDecl]+directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- stringLiteral;+ return [PDirective (do addLib cgn lib+ addIBC (IBCLib cgn lib))]+ <|> do try (lchar '%' *> reserved "link"); cgn <- codegen_; obj <- stringLiteral;+ return [PDirective (do dirs <- allImportDirs+ o <- liftIO $ findInPath dirs obj+ addIBC (IBCObj cgn obj) -- just name, search on loading ibc+ addObjectFile cgn o)]+ <|> do try (lchar '%' *> reserved "flag"); cgn <- codegen_;+ flag <- stringLiteral+ return [PDirective (do addIBC (IBCCGFlag cgn flag)+ addFlag cgn flag)]+ <|> do try (lchar '%' *> reserved "include"); cgn <- codegen_; hdr <- stringLiteral;+ return [PDirective (do addHdr cgn hdr+ addIBC (IBCHeader cgn hdr))]+ <|> do try (lchar '%' *> reserved "hide"); n <- iName []+ return [PDirective (do setAccessibility n Hidden+ addIBC (IBCAccess n Hidden))]+ <|> do try (lchar '%' *> reserved "freeze"); n <- iName []+ return [PDirective (do setAccessibility n Frozen+ addIBC (IBCAccess n Frozen))]+ <|> do try (lchar '%' *> reserved "access"); acc <- accessibility+ return [PDirective (do i <- get+ put(i { default_access = acc }))]+ <|> do try (lchar '%' *> reserved "default"); tot <- totality+ i <- get+ put (i { default_total = tot } )+ return [PDirective (do i <- get+ put(i { default_total = tot }))]+ <|> do try (lchar '%' *> reserved "logging"); i <- natural;+ return [PDirective (setLogLevel (fromInteger i))]+ <|> do try (lchar '%' *> reserved "dynamic"); libs <- sepBy1 stringLiteral (lchar ',');+ return [PDirective (do added <- addDyLib libs+ case added of+ Left lib -> addIBC (IBCDyLib (lib_name lib))+ Right msg ->+ fail $ msg)]+ <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;+ return [PDirective (addLangExt ext)]+ <?> "directive"++pLangExt :: IdrisParser LanguageExt+pLangExt = (reserved "TypeProviders" >> return TypeProviders)+ <|> (reserved "ErrorReflection" >> return ErrorReflection)++{- | Parses a totality+Totality ::= 'partial' | 'total'+-}+totality :: IdrisParser Bool+totality+ = do reserved "total"; return True+ <|> do reserved "partial"; return False++{- | Parses a type provider+Provider ::= '%' 'provide' '(' FnName TypeSig ')' 'with' Expr;+ -}+provider :: SyntaxInfo -> IdrisParser [PDecl]+provider syn = do try (lchar '%' *> reserved "provide");+ lchar '('; n <- fnName; lchar ':'; t <- typeExpr syn; lchar ')'+ fc <- getFC+ reserved "with"+ e <- expr syn+ return [PProvider syn fc n t e]+ <?> "type provider"++{- | Parses a transform+Transform ::= '%' 'transform' Expr '==>' Expr+-}+transform :: SyntaxInfo -> IdrisParser [PDecl]+transform syn = do try (lchar '%' *> reserved "transform")+ -- leave it unchecked, until we work out what this should+ -- actually mean...+-- safety <- option True (do reserved "unsafe"+-- return False)+ l <- expr syn+ fc <- getFC+ symbol "==>"+ r <- expr syn+ return [PTransform fc False l r]+ <?> "transform"+++{- * Loading and parsing -}+{- | Parses an expression from input -}+parseExpr :: IState -> String -> Result PTerm+parseExpr st = parseString (runInnerParser (evalStateT (fullExpr defaultSyntax) st)) (Directed (UTF8.fromString "(input)") 0 0 0 0)++{- | Parses a tactic from input -}+parseTactic :: IState -> String -> Result PTactic+parseTactic st = parseString (runInnerParser (evalStateT (fullTactic defaultSyntax) st)) (Directed (UTF8.fromString "(input)") 0 0 0 0)++-- | Parse module header and imports+parseImports :: FilePath -> String -> Idris ([String], [String], Maybe Delta)+parseImports fname input+ = do i <- getIState+ case parseString (runInnerParser (evalStateT imports i)) (Directed (UTF8.fromString fname) 0 0 0 0) input of+ Failure err -> fail (show err)+ Success (x, i) -> do -- Discard state updates (there should be+ -- none anyway)+ return x+ where imports :: IdrisParser (([String], [String], Maybe Delta), IState)+ imports = do whiteSpace+ mname <- moduleHeader+ ps <- many import_+ mrk <- mark+ isEof <- lookAheadMatches eof+ let mrk' = if isEof+ then Nothing+ else Just mrk+ i <- get+ return ((mname, ps, mrk'), i)+++-- | A program is a list of declarations, possibly with associated+-- documentation strings.+parseProg :: SyntaxInfo -> FilePath -> String -> Maybe Delta ->+ Idris [PDecl]+parseProg syn fname input mrk+ = do i <- getIState+ case parseString (runInnerParser (evalStateT mainProg i)) (Directed (UTF8.fromString fname) 0 0 0 0) input of+ Failure doc -> do iputStrLn (show doc)+ -- FIXME: Get error location from trifecta+ --let errl = sourceLine (errorPos err)+ i <- getIState+ putIState (i { errLine = Just 0 }) -- Just errl })+ return []+ Success (x, i) -> do putIState i+ return $ collect x+ where mainProg :: IdrisParser ([PDecl], IState)+ mainProg = case mrk of+ Nothing -> do i <- get; return ([], i)+ Just mrk -> do+ release mrk+ ds <- prog syn+ i' <- get+ return (ds, i')++{- | Load idris module -}+loadModule :: FilePath -> Idris String+loadModule f+ = idrisCatch (do i <- getIState+ let file = takeWhile (/= ' ') f+ ibcsd <- valIBCSubDir i+ ids <- allImportDirs+ fp <- liftIO $ findImport ids ibcsd file+ if file `elem` imported i+ then iLOG $ "Already read " ++ file+ else do putIState (i { imported = file : imported i })+ case fp of+ IDR fn -> loadSource False fn+ LIDR fn -> loadSource True fn+ IBC fn src ->+ idrisCatch (loadIBC fn)+ (\c -> do iLOG $ fn ++ " failed " ++ show c+ case src of+ IDR sfn -> loadSource False sfn+ LIDR sfn -> loadSource True sfn)+ let (dir, fh) = splitFileName file+ return (dropExtension fh))+ (\e -> do let msg = show e+ setErrLine (getErrLine msg)+ iputStrLn msg+ return "")++{- | Load idris code from file -}+loadFromIFile :: IFileType -> Idris ()+loadFromIFile i@(IBC fn src)+ = do iLOG $ "Skipping " ++ getSrcFile i+ idrisCatch (loadIBC fn)+ (\c -> do fail $ fn ++ " failed " ++ show c)+ where+ getSrcFile (IDR fn) = fn+ getSrcFile (LIDR fn) = fn+ getSrcFile (IBC f src) = getSrcFile src++loadFromIFile (IDR fn) = loadSource' False fn+loadFromIFile (LIDR fn) = loadSource' True fn++{-| Load idris source code and show error if something wrong happens -}+loadSource' :: Bool -> FilePath -> Idris ()+loadSource' lidr r+ = idrisCatch (loadSource lidr r)+ (\e -> do let msg = show e+ setErrLine (getErrLine msg)+ iputStrLn msg)++{- | Load Idris source code-}+loadSource :: Bool -> FilePath -> Idris ()+loadSource lidr f+ = do iLOG ("Reading " ++ f)+ i <- getIState+ let def_total = default_total i+ file_in <- liftIO $ readFile f+ file <- if lidr then tclift $ unlit f file_in else return file_in+ (mname, modules, pos) <- parseImports f file+ i <- getIState+ putIState (i { default_access = Hidden })+ clearIBC -- start a new .ibc file+ mapM_ (addIBC . IBCImport) modules+ ds' <- parseProg (defaultSyntax {syn_namespace = reverse mname })+ f file pos+ unless (null ds') $ do+ let ds = namespaces mname ds'+ logLvl 3 (dumpDecls ds)+ i <- getIState+ logLvl 10 (show (toAlist (idris_implicits i)))+ logLvl 3 (show (idris_infixes i))+ -- Now add all the declarations to the context+ v <- verbose+ when v $ iputStrLn $ "Type checking " ++ f+ -- we totality check after every Mutual block, so if+ -- anything is a single definition, wrap it in a+ -- mutual block on its own+ elabDecls toplevel (map toMutual ds)+ i <- getIState+ -- simplify every definition do give the totality checker+ -- a better chance+ mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n+ updateContext (simplifyCasedef n))+ (map snd (idris_totcheck i))+ -- build size change graph from simplified definitions+ iLOG "Totality checking"+ i <- getIState+ mapM_ buildSCG (idris_totcheck i)+ mapM_ checkDeclTotality (idris_totcheck i)+ iLOG ("Finished " ++ f)+ ibcsd <- valIBCSubDir i+ iLOG "Universe checking"+ iucheck+ let ibc = ibcPathNoFallback ibcsd f+ i <- getIState+ addHides (hide_list i)+ ok <- noErrors+ when ok $+ idrisCatch (do writeIBC f ibc; clearIBC)+ (\c -> return ()) -- failure is harmless+ i <- getIState+ putIState (i { default_total = def_total,+ hide_list = [] })+ return ()+ return ()+ where+ namespaces :: [String] -> [PDecl] -> [PDecl]+ namespaces [] ds = ds+ namespaces (x:xs) ds = [PNamespace x (namespaces xs ds)]++ toMutual :: PDecl -> PDecl+ toMutual m@(PMutual _ d) = m+ toMutual (PNamespace x ds) = PNamespace x (map toMutual ds)+ toMutual x = let r = PMutual (FC "single mutual" 0) [x] in+ case x of+ PClauses _ _ _ _ -> r+ PClass _ _ _ _ _ _ _ -> r+ PInstance _ _ _ _ _ _ _ _ -> r+ _ -> x++{- | Adds names to hide list -}+addHides :: [(Name, Maybe Accessibility)] -> Idris ()+addHides xs = do i <- getIState+ let defh = default_access i+ let (hs, as) = partition isNothing xs+ unless (null as) $+ mapM_ doHide+ (map (\ (n, _) -> (n, defh)) hs +++ map (\ (n, Just a) -> (n, a)) as)+ where isNothing (_, Nothing) = True+ isNothing _ = False++ doHide (n, a) = do setAccessibility n a+ addIBC (IBCAccess n a)
src/Idris/Prover.hs view
@@ -37,9 +37,9 @@ showProof :: Bool -> Name -> [String] -> String showProof lit n ps - = bird ++ show n ++ " = proof {" ++ break ++- showSep break (map (\x -> " " ++ x ++ ";") ps) ++- break ++ "}\n"+ = bird ++ show n ++ " = proof" ++ break +++ showSep break (map (\x -> " " ++ x) ps) +++ break ++ "\n" where bird = if lit then "> " else "" break = "\n" ++ bird
src/Idris/REPL.hs view
@@ -21,6 +21,7 @@ import Idris.Chaser import Idris.Imports import Idris.Colours+import Idris.Inliner import Paths_idris import Util.System@@ -63,6 +64,8 @@ import Data.Version import Data.Word (Word) +import qualified Text.PrettyPrint.ANSI.Leijen as ANSI+ import Debug.Trace -- | Run the REPL@@ -116,8 +119,9 @@ do let fn = case mods of (f:_) -> f _ -> ""+ c <- colourise case parseCmd i "(input)" cmd of- Failure err -> iFail $ show err+ Failure err -> iFail $ show (fixColour c err) Success (Prove n') -> do iResult "" idrisCatch (do process fn (Prove n'))@@ -217,8 +221,9 @@ let fn = case inputs of (f:_) -> f _ -> ""+ c <- colourise case parseCmd i "(input)" cmd of- Failure err -> do liftIO $ print err+ Failure err -> do liftIO $ print (fixColour c err) return (Just inputs) Success Reload -> do putIState $ orig { idris_options = idris_options i@@ -277,7 +282,9 @@ let cmd = editor ++ line ++ f liftIO $ system cmd clearErr- putIState (orig { idris_options = idris_options i })+ putIState $ orig { idris_options = idris_options i+ , idris_colourTheme = idris_colourTheme i+ } loadInputs [f] iucheck return ()@@ -489,6 +496,13 @@ ist <- getIState let tm' = hnf ctxt [] tm iResult (show (delab ist tm'))+process fn (TestInline t) = do (tm, ty) <- elabVal toplevel False t+ ctxt <- getContext+ ist <- getIState+ let tm' = inlineTerm ist tm+ imp <- impShow+ c <- colourise+ iResult (showImp (Just ist) imp c (delab ist tm')) process fn TTShell = do ist <- getIState let shst = initState (tt_ctxt ist) runShell shst@@ -646,6 +660,7 @@ parseArgs ["--exec"] = InterpretScript "Main.main" : [] parseArgs ("--exec":expr:ns) = InterpretScript expr : parseArgs ns parseArgs ("-XTypeProviders":ns) = Extension TypeProviders : (parseArgs ns)+parseArgs ("-XErrorReflection":ns) = Extension ErrorReflection : (parseArgs ns) parseArgs ("-O3":ns) = OptLevel 3 : parseArgs ns parseArgs ("-O2":ns) = OptLevel 2 : parseArgs ns parseArgs ("-O1":ns) = OptLevel 1 : parseArgs ns@@ -840,14 +855,20 @@ execScript :: String -> Idris () execScript expr = do i <- getIState+ c <- colourise case parseExpr i expr of- Failure err -> do iputStrLn $ show err- liftIO $ exitWith (ExitFailure 1)- Success term -> do ctxt <- getContext- (tm, _) <- elabVal toplevel False term- res <- execute tm- liftIO $ exitWith ExitSuccess+ Failure err -> do iputStrLn $ show (fixColour c err)+ liftIO $ exitWith (ExitFailure 1)+ Success term -> do ctxt <- getContext+ (tm, _) <- elabVal toplevel False term+ res <- execute tm+ liftIO $ exitWith ExitSuccess +-- | Check if the coloring matches the options and corrects if necessary+fixColour :: Bool -> ANSI.Doc -> ANSI.Doc+fixColour False doc = ANSI.plain doc+fixColour True doc = doc+ -- | Get the platform-specific, user-specific Idris dir getIdrisUserDataDir :: Idris FilePath getIdrisUserDataDir = liftIO $ getAppUserDataDirectory "idris"@@ -872,11 +893,12 @@ unless eof $ do line <- liftIO $ hGetLine h script <- getInitScript- processLine ist line script+ c <- colourise+ processLine ist line script c runInit h- processLine i cmd input =+ processLine i cmd input clr = case parseCmd i input cmd of- Failure err -> liftIO $ print err+ Failure err -> liftIO $ print (fixColour clr err) Success Reload -> iFail "Init scripts cannot reload the file" Success (Load f) -> iFail "Init scripts cannot load files" Success (ModImport f) -> iFail "Init scripts cannot import modules"
src/Idris/REPLParser.hs view
@@ -23,7 +23,7 @@ import qualified Data.ByteString.UTF8 as UTF8 parseCmd :: IState -> String -> String -> Result Command-parseCmd i inputname = parseString (evalStateT pCmd i) (Directed (UTF8.fromString inputname) 0 0 0 0)+parseCmd i inputname = parseString (P.runInnerParser (evalStateT pCmd i)) (Directed (UTF8.fromString inputname) 0 0 0 0) cmd :: [String] -> P.IdrisParser () cmd xs = do P.lchar ':'; docmd (sortBy (\x y -> compare (length y) (length x)) xs)@@ -55,6 +55,7 @@ <|> try (do cmd ["cd"]; f <- many anyChar; return (ChangeDirectory f)) <|> try (do cmd ["spec"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Spec t)) <|> try (do cmd ["hnf"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (HNF t))+ <|> try (do cmd ["inline"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (TestInline t)) <|> try (do cmd ["doc"]; n <- P.fnName; eof; return (DocStr n)) <|> try (do cmd ["d", "def"]; some (P.char ' ') ; n <- P.fnName; eof; return (Defn n)) <|> try (do cmd ["total"]; do n <- P.fnName; eof; return (TotCheck n))@@ -104,6 +105,8 @@ <|> try (P.symbol "nounderline" >> return doNoUnderline) <|> try (P.symbol "bold" >> return doBold) <|> try (P.symbol "nobold" >> return doNoBold)+ <|> try (P.symbol "italic" >> return doItalic)+ <|> try (P.symbol "noitalic" >> return doNoItalic) <|> try (pColour >>= return . doSetColour) where doVivid i = i { vivid = True } doDull i = i { vivid = False }@@ -111,6 +114,8 @@ doNoUnderline i = i { underline = False } doBold i = i { bold = True } doNoBold i = i { bold = False }+ doItalic i = i { italic = True }+ doNoItalic i = i { italic = False } doSetColour c i = i { colour = c } @@ -126,7 +131,7 @@ pSetColourCmd :: P.IdrisParser Command pSetColourCmd = (do c <- pColourType- let defaultColour = IdrisColour Black True False False+ let defaultColour = IdrisColour Black True False False False opts <- sepBy pColourMod (P.whiteSpace) let colour = foldr ($) defaultColour $ reverse opts return $ SetColour c colour)
src/Pkg/Package.hs view
@@ -20,7 +20,7 @@ import Pkg.PParser -import Paths_idris+import Paths_idris (getDataDir) -- To build a package: -- * read the package description@@ -98,8 +98,7 @@ installIBC :: String -> Name -> IO () installIBC p m = do let f = toIBCFile m- target <- environment "TARGET"- d <- maybe getDataDir return target+ d <- getTargetDir let destdir = d </> p </> getDest m putStrLn $ "Installing " ++ f ++ " to " ++ destdir createDirectoryIfMissing True destdir@@ -109,7 +108,7 @@ getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : ns)) installObj :: String -> String -> IO ()-installObj p o = do d <- getDataDir+installObj p o = do d <- getTargetDir let destdir = addTrailingPathSeparator (d </> p) putStrLn $ "Installing " ++ o ++ " to " ++ destdir createDirectoryIfMissing True destdir
src/Util/System.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-module Util.System(tempfile,withTempdir,environment,getCC,+module Util.System(tempfile,withTempdir,getTargetDir,getCC, getLibFlags,getIdrisLibDir,getIncFlags,rmFile, getMvn,getExecutablePom,catchIO) where @@ -63,6 +63,9 @@ environment x = catchIO (do e <- getEnv x return (Just e)) (\_ -> return Nothing)++getTargetDir :: IO String+getTargetDir = environment "TARGET" >>= maybe getDataDir return rmFile :: FilePath -> IO () rmFile f = do putStrLn $ "Removing " ++ f
test/Makefile view
@@ -57,6 +57,42 @@ @perl ./runtest.pl test026 --codegen node @perl ./runtest.pl test027 --codegen node @perl ./runtest.pl test028 --codegen node+ @perl ./runtest.pl test029 --codegen node+ @perl ./runtest.pl test030 --codegen node+ @perl ./runtest.pl test031 --codegen node++test_llvm:+ @perl ./runtest.pl test001 --codegen llvm+ @perl ./runtest.pl test002 --codegen llvm+ @perl ./runtest.pl test003 --codegen llvm+ @perl ./runtest.pl test004 --codegen llvm+ @perl ./runtest.pl test005 --codegen llvm+ @perl ./runtest.pl test006 --codegen llvm+ @perl ./runtest.pl test007 --codegen llvm+ @perl ./runtest.pl test008 --codegen llvm+ @perl ./runtest.pl test009 --codegen llvm+ @perl ./runtest.pl test010 --codegen llvm+ @perl ./runtest.pl test011 --codegen llvm+ @perl ./runtest.pl test012 --codegen llvm+ @perl ./runtest.pl test013 --codegen llvm+ @perl ./runtest.pl test014 --codegen llvm+ @perl ./runtest.pl test015 --codegen llvm+ @perl ./runtest.pl test016 --codegen llvm+ @perl ./runtest.pl test017 --codegen llvm+ @#perl ./runtest.pl test018 --codegen llvm+ @perl ./runtest.pl test019 --codegen llvm+ @perl ./runtest.pl test020 --codegen llvm+ @perl ./runtest.pl test021 --codegen llvm+ @perl ./runtest.pl test022 --codegen llvm+ @perl ./runtest.pl test023 --codegen llvm+ @perl ./runtest.pl test024 --codegen llvm+ @perl ./runtest.pl test025 --codegen llvm+ @perl ./runtest.pl test026 --codegen llvm+ @perl ./runtest.pl test027 --codegen llvm+ @perl ./runtest.pl test028 --codegen llvm+ @perl ./runtest.pl test029 --codegen llvm+ @perl ./runtest.pl test030 --codegen llvm+ @perl ./runtest.pl test031 --codegen llvm update: perl ./runtest.pl all -u
test/reg007/expected view
@@ -1,1 +1,13 @@ reg007.lidr:8:A.n is already defined+reg007.lidr:12:When elaborating right hand side of hurrah:+Can't unify+ [92mn[0m[94m = [0m[92mA.lala[0m+with+ [91m0[0m[94m = [0m[91m1[0m++Specifically:+ Can't unify+ [91m1[0m+ with+ [91m0[0m+
test/reg007/reg007.lidr view
@@ -5,8 +5,8 @@ > isSame : A.n = A.lala > isSame = refl -> A.n = O -- This is where it's at!-> A.lala = S O+> A.n = Z -- This is where it's at!+> A.lala = S Z -> hurrah : O = S O+> hurrah : Z = S Z > hurrah = isSame
+ test/reg021/expected view
+ test/reg021/reg021.idr view
@@ -0,0 +1,22 @@+module Main++%default total++data Ty = TyBool++data Id a = I a++interpTy : Ty -> Type+interpTy TyBool = Id Bool++data Term : Ty -> Type where+ TLit : Bool -> Term TyBool+ TNot : Term TyBool -> Term TyBool++map : (a -> b) -> Id a -> Id b+map f (I x) = I (f x)++interp : Term t -> interpTy t+interp (TLit x) = I x+interp (TNot x) = map not (interp x)+
+ test/reg021/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ reg021.idr --check+rm -f *.ibc
+ test/reg022/expected view
+ test/reg022/reg022.idr view
@@ -0,0 +1,18 @@+module reg022++data Result str a = Success str a | Failure String++instance Functor (Result str) where+ map f (Success s x) = Success s (f x)+ map f (Failure e ) = Failure e++ParserT : (Type -> Type) -> Type -> Type -> Type+ParserT m str a = str -> m (Result str a)++ap : Monad m => ParserT m str (a -> b) -> ParserT m str a -> + ParserT m str b+ap f x = \s => do f' <- f s+ case f' of+ Failure e => (pure (Failure e))+ Success s' g => x s' >>= pure . map g+
+ test/reg022/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ reg022.idr --check+rm -f *.ibc
+ test/reg023/expected view
@@ -0,0 +1,12 @@+reg023.idr:7:When elaborating right hand side of bad:+Can't unify+ [94mNat[0m+with+ [92mf[0m [94mNat[0m++Specifically:+ Can't unify+ [94mNat[0m+ with+ [92mf[0m [94mNat[0m+
+ test/reg023/reg023.idr view
@@ -0,0 +1,8 @@+module Foo++f : Type -> Type+f x = f x++bad : f Nat+bad = Z+
+ test/reg023/run view
@@ -0,0 +1,3 @@+#!/bin/bash+idris $@ reg023.idr --check+rm -f *.ibc
+ test/reg024/expected view
@@ -0,0 +1,1 @@+The answer is 42
+ test/reg024/reg024.idr view
@@ -0,0 +1,31 @@+module Main++data Format = End | FInt Format | FStr Format | FChar Char Format++fromList : List Char -> Format+fromList Nil = End+fromList ('%' :: 'd' :: cs) = FInt (fromList cs)+fromList ('%' :: 's' :: cs) = FStr (fromList cs)+fromList (c :: cs) = FChar c (fromList cs)++PrintfType : Format -> Type+PrintfType End = String+PrintfType (FInt rest) = Int -> PrintfType rest+PrintfType (FStr rest) = String -> PrintfType rest+PrintfType (FChar c rest) = PrintfType rest++printf : (fmt: String) -> PrintfType (fromList $ unpack fmt)+printf fmt = printFormat (fromList $ unpack fmt) where+ printFormat : (fmt: Format) -> PrintfType fmt+ printFormat fmt = rec fmt "" where+ rec : (f: Format) -> String -> PrintfType f+ rec End acc = acc+ rec (FInt rest) acc = \i: Int => rec rest (acc ++ (show i))+ rec (FStr rest) acc = \s: String => rec rest (acc ++ s)+ rec (FChar c rest) acc = rec rest (acc ++ (pack [c]))++test : String+test = printf "The %s is %d" "answer" 42++main : IO ()+main = print test
+ test/reg024/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ reg024.idr -o reg024+./reg024+rm -f reg024 *.ibc
test/runtest.pl view
@@ -1,8 +1,10 @@ #!/usr/bin/perl +use strict; use Cwd; my $exitstatus = 0;+my @idrOpts = (); sub runtest { my ($test, $update) = @_;@@ -10,101 +12,101 @@ chdir($test); print "Running $test...\n";- $got = `sh ./run @idrOpts`;- $exp = `cat expected`;+ my $got = `sh ./run @idrOpts`;+ my $exp = `cat expected`; - open(OUT,">output");- print OUT $got;- close(OUT);+ open my $out, '>', 'output';+ print $out $got;+ close $out; -# $ok = system("diff output expected &> /dev/null");-# Mangle newlines in $got and $exp+ # $ok = system("diff output expected &> /dev/null");+ # Mangle newlines in $got and $exp $got =~ s/\r\n/\n/g; $exp =~ s/\r\n/\n/g; -# Normalize paths in $got and $exp, so the expected outcomes don't change between platforms- while($got =~ /(^|.*?\n)(.*?)\\(.*?):(\d+):(.*)/ms)- {+ # Normalize paths in $got and $exp, so the expected outcomes don't + # change between platforms+ while($got =~ /(^|.*?\n)(.*?)\\(.*?):(\d+):(.*)/ms) { $got = "$1$2/$3:$4:$5"; }- while($exp =~ /(^|.*?\n)(.*?)\\(.*?):(\d+):(.*)/ms)- {+ while($exp =~ /(^|.*?\n)(.*?)\\(.*?):(\d+):(.*)/ms) { $exp = "$1$2/$3:$4:$5"; } if ($got eq $exp) {- print "Ran $test...success\n";- } else {- if ($update == 0) {- $exitstatus = 1;- print "Ran $test...FAILURE\n";- } else {- system("cp output expected");- print "Ran $test...UPDATED\n";- }+ print "Ran $test...success\n";+ } + else {+ if ($update == 0) {+ $exitstatus = 1;+ print "Ran $test...FAILURE\n";+ } else {+ system("cp output expected");+ print "Ran $test...UPDATED\n";+ } }- chdir("..");+ chdir ".."; } +my ( @tests, @opts );+ if ($#ARGV>=0) {- $test=shift(@ARGV);+ my $test = shift @ARGV; if ($test eq "all") {- opendir(DIR, ".");- @list = readdir(DIR);- foreach $file (@list) {- if ($file =~ /[0-9][0-9][0-9]/) {- push(@tests,$file);- }- }- @tests = sort @tests;+ opendir my $dir, ".";+ my @list = readdir $dir;+ foreach my $file (@list) {+ if ($file =~ /[0-9][0-9][0-9]/) {+ push @tests, $file;+ }+ }+ @tests = sort @tests; }- else- {- push(@tests, $test);+ else {+ push @tests, $test; } @opts = @ARGV;-} else {+} +else { print "Give a test name, or 'all' to run all.\n"; exit; } -$update=0;-$diff=0;-$show=0;-$usejava = 0;-@idrOpts=();+my $update = 0;+my $diff = 0;+my $show = 0;+my $usejava = 0; -while ($opt=shift(@opts)) {- if ($opt eq "-u") { $update = 1; }+while (my $opt = shift @opts) {+ if ($opt eq "-u") { $update = 1; } elsif ($opt eq "-d") { $diff = 1; } elsif ($opt eq "-s") { $show = 1; } else { push(@idrOpts, $opt); } } -my $idris = $ENV{IDRIS};-my $path = $ENV{PATH};-$ENV{PATH}=cwd() . "/" . $idris . ":" . $path;--foreach $test (@tests) {+my $idris = $ENV{IDRIS};+my $path = $ENV{PATH};+$ENV{PATH} = cwd() . "/" . $idris . ":" . $path; +foreach my $test (@tests) { if ($diff == 0 && $show == 0) {- runtest($test,$update);+ runtest($test,$update); } else {- chdir($test);+ chdir $test; - if ($show == 1) {- system("cat output");- }- if ($diff == 1) {- print "Differences in $test:\n";- $ok = system("diff output expected");- if ($ok == 0) {- print "No differences found.\n";- }- }- chdir("..");+ if ($show == 1) {+ system "cat output";+ }+ if ($diff == 1) {+ print "Differences in $test:\n";+ my $ok = system "diff output expected";+ if ($ok == 0) {+ print "No differences found.\n";+ }+ }+ chdir ".."; }- }+ exit $exitstatus;
test/test030/Reflect.idr view
@@ -1,6 +1,7 @@ module Reflect import Decidable.Equality+%default total using (xs : List a, ys : List a, G : List (List a))
+ test/test031/expected view
+ test/test031/run view
@@ -0,0 +1,4 @@+#!/bin/bash+idris $@ test031.idr -o test031+./test031+rm -f test031 *.ibc
+ test/test031/test031.idr view
@@ -0,0 +1,8 @@+module Main++-- Test enabling the ErrorReflection extension++%language ErrorReflection++main : IO ()+main = return ()