diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 + } diff --git a/effects/Effects.idr b/effects/Effects.idr --- a/effects/Effects.idr +++ b/effects/Effects.idr @@ -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) diff --git a/effects/Makefile b/effects/Makefile --- a/effects/Makefile +++ b/effects/Makefile @@ -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: diff --git a/idris.cabal b/idris.cabal --- a/idris.cabal +++ b/idris.cabal @@ -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 . + related to Epigram and Agda. There is a tutorial at + . 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 diff --git a/javascript/Makefile b/javascript/Makefile --- a/javascript/Makefile +++ b/javascript/Makefile @@ -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: diff --git a/js/Runtime-browser.js b/js/Runtime-browser.js deleted file mode 100644 --- a/js/Runtime-browser.js +++ /dev/null @@ -1,3 +0,0 @@ -var __IDRRT__print = function(s) { - console.log(s); -}; diff --git a/js/Runtime-common.js b/js/Runtime-common.js deleted file mode 100644 --- a/js/Runtime-common.js +++ /dev/null @@ -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; -})(); diff --git a/js/Runtime-node.js b/js/Runtime-node.js deleted file mode 100644 --- a/js/Runtime-node.js +++ /dev/null @@ -1,6 +0,0 @@ -var __IDRRT__print = (function() { - var util = require('util'); - return function(s) { - util.print(s); - }; -})(); diff --git a/jsrts/Runtime-browser.js b/jsrts/Runtime-browser.js new file mode 100644 --- /dev/null +++ b/jsrts/Runtime-browser.js @@ -0,0 +1,3 @@ +var __IDRRT__print = function(s) { + console.log(s); +}; diff --git a/jsrts/Runtime-common.js b/jsrts/Runtime-common.js new file mode 100644 --- /dev/null +++ b/jsrts/Runtime-common.js @@ -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; +}; diff --git a/jsrts/Runtime-node.js b/jsrts/Runtime-node.js new file mode 100644 --- /dev/null +++ b/jsrts/Runtime-node.js @@ -0,0 +1,6 @@ +var __IDRRT__print = (function() { + var util = require('util'); + return function(s) { + util.print(s); + }; +})(); diff --git a/jsrts/jsbn/LICENSE b/jsrts/jsbn/LICENSE new file mode 100644 --- /dev/null +++ b/jsrts/jsbn/LICENSE @@ -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 diff --git a/jsrts/jsbn/jsbn.js b/jsrts/jsbn/jsbn.js new file mode 100644 --- /dev/null +++ b/jsrts/jsbn/jsbn.js @@ -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<= 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))<>(this.DB-sh)); + } + else + this[this.t-1] |= x<= 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)< 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< 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+=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<= 0; --i) { + r[i+ds+1] = (this[i]>>cbs)|c; + c = (this[i]&bm)<= 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; + for(var i = ds+1; i < this.t; ++i) { + r[i-ds-1] |= (this[i]&bm)<>bs; + } + if(bs > 0) r[this.t-ds-1] |= (this.s&bm)<>= 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<1)?y[ys-2]>>this.F2:0); + var d1 = this.FV/yt, d2 = (1<= 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< 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))<>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< 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+=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<>= 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< 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< 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); +} +})(); diff --git a/lib/Data/Bits.idr b/lib/Data/Bits.idr --- a/lib/Data/Bits.idr +++ b/lib/Data/Bits.idr @@ -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 diff --git a/lib/Decidable/Equality.idr b/lib/Decidable/Equality.idr --- a/lib/Decidable/Equality.idr +++ b/lib/Decidable/Equality.idr @@ -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)) diff --git a/lib/Language/Reflection/Errors.idr b/lib/Language/Reflection/Errors.idr new file mode 100644 --- /dev/null +++ b/lib/Language/Reflection/Errors.idr @@ -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 diff --git a/lib/Makefile b/lib/Makefile --- a/lib/Makefile +++ b/lib/Makefile @@ -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: diff --git a/lib/Prelude.idr b/lib/Prelude.idr --- a/lib/Prelude.idr +++ b/lib/Prelude.idr @@ -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) diff --git a/lib/Prelude/Bits.idr b/lib/Prelude/Bits.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Bits.idr @@ -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 diff --git a/lib/Prelude/Chars.idr b/lib/Prelude/Chars.idr --- a/lib/Prelude/Chars.idr +++ b/lib/Prelude/Chars.idr @@ -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'] + diff --git a/lib/base.ipkg b/lib/base.ipkg --- a/lib/base.ipkg +++ b/lib/base.ipkg @@ -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, diff --git a/llvm/Makefile b/llvm/Makefile --- a/llvm/Makefile +++ b/llvm/Makefile @@ -5,7 +5,7 @@ OBJECTS=$(SOURCES:.c=.o) LIB=libidris_rts.a -all: $(SOURCES) $(LIB) +build: $(SOURCES) $(LIB) $(LIB): $(OBJECTS) ar r $@ $(OBJECTS) diff --git a/llvm/defs.c b/llvm/defs.c --- a/llvm/defs.c +++ b/llvm/defs.c @@ -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) */ diff --git a/rts/Makefile b/rts/Makefile --- a/rts/Makefile +++ b/rts/Makefile @@ -9,7 +9,7 @@ LIBTARGET = libidris_rts.a -check : $(LIBTARGET) $(DYLIBTARGET) +build: $(LIBTARGET) $(DYLIBTARGET) $(LIBTARGET) : $(OBJS) ar r $(LIBTARGET) $(OBJS) diff --git a/rts/idris_rts.c b/rts/idris_rts.c --- a/rts/idris_rts.c +++ b/rts/idris_rts.c @@ -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; } diff --git a/src/Core/ProofState.hs b/src/Core/ProofState.hs --- a/src/Core/ProofState.hs +++ b/src/Core/ProofState.hs @@ -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', diff --git a/src/Core/TT.hs b/src/Core/TT.hs --- a/src/Core/TT.hs +++ b/src/Core/TT.hs @@ -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 diff --git a/src/Core/Unify.hs b/src/Core/Unify.hs --- a/src/Core/Unify.hs +++ b/src/Core/Unify.hs @@ -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 diff --git a/src/IRTS/CodegenJavaScript.hs b/src/IRTS/CodegenJavaScript.hs --- a/src/IRTS/CodegenJavaScript.hs +++ b/src/IRTS/CodegenJavaScript.hs @@ -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" ] diff --git a/src/IRTS/CodegenLLVM.hs b/src/IRTS/CodegenLLVM.hs --- a/src/IRTS/CodegenLLVM.hs +++ b/src/IRTS/CodegenLLVM.hs @@ -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 diff --git a/src/IRTS/Simplified.hs b/src/IRTS/Simplified.hs --- a/src/IRTS/Simplified.hs +++ b/src/IRTS/Simplified.hs @@ -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 diff --git a/src/Idris/AbsSyntax.hs b/src/Idris/AbsSyntax.hs --- a/src/Idris/AbsSyntax.hs +++ b/src/Idris/AbsSyntax.hs @@ -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 diff --git a/src/Idris/AbsSyntaxTree.hs b/src/Idris/AbsSyntaxTree.hs --- a/src/Idris/AbsSyntaxTree.hs +++ b/src/Idris/AbsSyntaxTree.hs @@ -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 _ = [] + diff --git a/src/Idris/Colours.hs b/src/Idris/Colours.hs --- a/src/Idris/Colours.hs +++ b/src/Idris/Colours.hs @@ -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) diff --git a/src/Idris/Completion.hs b/src/Idris/Completion.hs --- a/src/Idris/Completion.hs +++ b/src/Idris/Completion.hs @@ -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) diff --git a/src/Idris/Coverage.hs b/src/Idris/Coverage.hs --- a/src/Idris/Coverage.hs +++ b/src/Idris/Coverage.hs @@ -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) diff --git a/src/Idris/DSL.hs b/src/Idris/DSL.hs --- a/src/Idris/DSL.hs +++ b/src/Idris/DSL.hs @@ -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 diff --git a/src/Idris/Delaborate.hs b/src/Idris/Delaborate.hs --- a/src/Idris/Delaborate.hs +++ b/src/Idris/Delaborate.hs @@ -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 diff --git a/src/Idris/Docs.hs b/src/Idris/Docs.hs --- a/src/Idris/Docs.hs +++ b/src/Idris/Docs.hs @@ -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) diff --git a/src/Idris/ElabDecls.hs b/src/Idris/ElabDecls.hs --- a/src/Idris/ElabDecls.hs +++ b/src/Idris/ElabDecls.hs @@ -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) }) diff --git a/src/Idris/ElabTerm.hs b/src/Idris/ElabTerm.hs --- a/src/Idris/ElabTerm.hs +++ b/src/Idris/ElabTerm.hs @@ -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 diff --git a/src/Idris/IBC.hs b/src/Idris/IBC.hs --- a/src/Idris/IBC.hs +++ b/src/Idris/IBC.hs @@ -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 diff --git a/src/Idris/ParseData.hs b/src/Idris/ParseData.hs new file mode 100644 --- /dev/null +++ b/src/Idris/ParseData.hs @@ -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"] + + diff --git a/src/Idris/ParseExpr.hs b/src/Idris/ParseExpr.hs new file mode 100644 --- /dev/null +++ b/src/Idris/ParseExpr.hs @@ -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 diff --git a/src/Idris/ParseHelpers.hs b/src/Idris/ParseHelpers.hs new file mode 100644 --- /dev/null +++ b/src/Idris/ParseHelpers.hs @@ -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 [] = [] + diff --git a/src/Idris/ParseOps.hs b/src/Idris/ParseOps.hs new file mode 100644 --- /dev/null +++ b/src/Idris/ParseOps.hs @@ -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" + diff --git a/src/Idris/Parser.hs b/src/Idris/Parser.hs --- a/src/Idris/Parser.hs +++ b/src/Idris/Parser.hs @@ -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) diff --git a/src/Idris/Prover.hs b/src/Idris/Prover.hs --- a/src/Idris/Prover.hs +++ b/src/Idris/Prover.hs @@ -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 diff --git a/src/Idris/REPL.hs b/src/Idris/REPL.hs --- a/src/Idris/REPL.hs +++ b/src/Idris/REPL.hs @@ -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" diff --git a/src/Idris/REPLParser.hs b/src/Idris/REPLParser.hs --- a/src/Idris/REPLParser.hs +++ b/src/Idris/REPLParser.hs @@ -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) diff --git a/src/Pkg/Package.hs b/src/Pkg/Package.hs --- a/src/Pkg/Package.hs +++ b/src/Pkg/Package.hs @@ -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 diff --git a/src/Util/System.hs b/src/Util/System.hs --- a/src/Util/System.hs +++ b/src/Util/System.hs @@ -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 diff --git a/test/Makefile b/test/Makefile --- a/test/Makefile +++ b/test/Makefile @@ -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 diff --git a/test/reg007/expected b/test/reg007/expected --- a/test/reg007/expected +++ b/test/reg007/expected @@ -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 + n = A.lala +with + 0 = 1 + +Specifically: + Can't unify + 1 + with + 0 + diff --git a/test/reg007/reg007.lidr b/test/reg007/reg007.lidr --- a/test/reg007/reg007.lidr +++ b/test/reg007/reg007.lidr @@ -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 diff --git a/test/reg021/expected b/test/reg021/expected new file mode 100644 --- /dev/null +++ b/test/reg021/expected diff --git a/test/reg021/reg021.idr b/test/reg021/reg021.idr new file mode 100644 --- /dev/null +++ b/test/reg021/reg021.idr @@ -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) + diff --git a/test/reg021/run b/test/reg021/run new file mode 100644 --- /dev/null +++ b/test/reg021/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ reg021.idr --check +rm -f *.ibc diff --git a/test/reg022/expected b/test/reg022/expected new file mode 100644 --- /dev/null +++ b/test/reg022/expected diff --git a/test/reg022/reg022.idr b/test/reg022/reg022.idr new file mode 100644 --- /dev/null +++ b/test/reg022/reg022.idr @@ -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 + diff --git a/test/reg022/run b/test/reg022/run new file mode 100644 --- /dev/null +++ b/test/reg022/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ reg022.idr --check +rm -f *.ibc diff --git a/test/reg023/expected b/test/reg023/expected new file mode 100644 --- /dev/null +++ b/test/reg023/expected @@ -0,0 +1,12 @@ +reg023.idr:7:When elaborating right hand side of bad: +Can't unify + Nat +with + f Nat + +Specifically: + Can't unify + Nat + with + f Nat + diff --git a/test/reg023/reg023.idr b/test/reg023/reg023.idr new file mode 100644 --- /dev/null +++ b/test/reg023/reg023.idr @@ -0,0 +1,8 @@ +module Foo + +f : Type -> Type +f x = f x + +bad : f Nat +bad = Z + diff --git a/test/reg023/run b/test/reg023/run new file mode 100644 --- /dev/null +++ b/test/reg023/run @@ -0,0 +1,3 @@ +#!/bin/bash +idris $@ reg023.idr --check +rm -f *.ibc diff --git a/test/reg024/expected b/test/reg024/expected new file mode 100644 --- /dev/null +++ b/test/reg024/expected @@ -0,0 +1,1 @@ +The answer is 42 diff --git a/test/reg024/reg024.idr b/test/reg024/reg024.idr new file mode 100644 --- /dev/null +++ b/test/reg024/reg024.idr @@ -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 diff --git a/test/reg024/run b/test/reg024/run new file mode 100644 --- /dev/null +++ b/test/reg024/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ reg024.idr -o reg024 +./reg024 +rm -f reg024 *.ibc diff --git a/test/runtest.pl b/test/runtest.pl --- a/test/runtest.pl +++ b/test/runtest.pl @@ -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; diff --git a/test/test030/Reflect.idr b/test/test030/Reflect.idr --- a/test/test030/Reflect.idr +++ b/test/test030/Reflect.idr @@ -1,6 +1,7 @@ module Reflect import Decidable.Equality +%default total using (xs : List a, ys : List a, G : List (List a)) diff --git a/test/test031/expected b/test/test031/expected new file mode 100644 --- /dev/null +++ b/test/test031/expected diff --git a/test/test031/run b/test/test031/run new file mode 100644 --- /dev/null +++ b/test/test031/run @@ -0,0 +1,4 @@ +#!/bin/bash +idris $@ test031.idr -o test031 +./test031 +rm -f test031 *.ibc diff --git a/test/test031/test031.idr b/test/test031/test031.idr new file mode 100644 --- /dev/null +++ b/test/test031/test031.idr @@ -0,0 +1,8 @@ +module Main + +-- Test enabling the ErrorReflection extension + +%language ErrorReflection + +main : IO () +main = return ()