diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -50,13 +50,6 @@ -- ----------------------------------------------------------------------------- -- Flags -usesLLVM :: S.ConfigFlags -> Bool -usesLLVM flags = - case lookup (FlagName "llvm") (S.configConfigurationsFlags flags) of - Just True -> True - Just False -> False - Nothing -> True - usesGMP :: S.ConfigFlags -> Bool usesGMP flags = case lookup (FlagName "gmp") (S.configConfigurationsFlags flags) of @@ -82,15 +75,12 @@ idrisClean _ flags _ _ = do cleanStdLib - cleanLLVM where verbosity = S.fromFlag $ S.cleanVerbosity flags cleanStdLib = do makeClean "libs" - cleanLLVM = makeClean "llvm" - makeClean dir = make verbosity [ "-C", dir, "clean", "IDRIS=idris" ] @@ -189,7 +179,6 @@ idrisBuild _ flags _ local = do buildStdLib buildRTS - when (usesLLVM $ configFlags local) buildLLVM where verbosity = S.fromFlag $ S.buildVerbosity flags @@ -202,8 +191,6 @@ buildRTS = make verbosity (["-C", "rts", "build"] ++ gmpflag (usesGMP (configFlags local))) - buildLLVM = make verbosity ["-C", "llvm", "build"] - gmpflag False = [] gmpflag True = ["GMP=-DIDRIS_GMP"] @@ -215,7 +202,6 @@ idrisInstall verbosity copy pkg local = do installStdLib installRTS - when (usesLLVM $ configFlags local) installLLVM where target = datadir $ L.absoluteInstallDirs pkg local copy @@ -227,11 +213,6 @@ 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] diff --git a/codegen/idris-c/Main.hs b/codegen/idris-c/Main.hs deleted file mode 100644 --- a/codegen/idris-c/Main.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Main where - -import Idris.Core.TT -import Idris.AbsSyntax -import Idris.ElabDecls -import Idris.REPL - -import IRTS.Compiler -import IRTS.CodegenC - -import System.Environment -import System.Exit - -import Paths_idris - -data Opts = Opts { inputs :: [FilePath], - output :: FilePath } - -showUsage = do putStrLn "Usage: idris-c [-o ]" - exitWith ExitSuccess - -getOpts :: IO Opts -getOpts = do xs <- getArgs - return $ process (Opts [] "a.out") xs - where - process opts ("-o":o:xs) = process (opts { output = o }) xs - process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs - process opts [] = opts - -c_main :: Opts -> Idris () -c_main opts = do elabPrims - loadInputs (inputs opts) Nothing - mainProg <- elabMain - ir <- compile (Via "c") (output opts) mainProg - runIO $ codegenC ir - -main :: IO () -main = do opts <- getOpts - if (null (inputs opts)) - then showUsage - else runMain (c_main opts) - - - diff --git a/config.mk b/config.mk --- a/config.mk +++ b/config.mk @@ -1,6 +1,9 @@ CC ?=cc CABAL :=cabal -CFLAGS :=-O2 -Wall -DHAS_PTHREAD $(CFLAGS) +# IDRIS_ENABLE_STATS should not be set in final release +# Any flags defined here which alter the RTS API must also be added to src/IRTS/CodegenC.hs +CFLAGS :=-O2 -Wall -DHAS_PTHREAD -DIDRIS_ENABLE_STATS $(CFLAGS) + #CABALFLAGS := ## Disable building of Effects #CABALFLAGS :=-f NoEffects diff --git a/idris.cabal b/idris.cabal --- a/idris.cabal +++ b/idris.cabal @@ -1,5 +1,5 @@ Name: idris -Version: 0.9.14.3 +Version: 0.9.15 License: BSD3 License-file: LICENSE Author: Edwin Brady @@ -52,12 +52,28 @@ jsrts/Runtime-node.js jsrts/jsbn/jsbn.js jsrts/jsbn/LICENSE + rts/arduino/idris_main.c + rts/idris_bitstring.c + rts/idris_bitstring.h + rts/idris_gc.c rts/idris_gc.h + rts/idris_gmp.c rts/idris_gmp.h + rts/idris_heap.c + rts/idris_heap.h rts/idris_main.c - rts/idris_rts.h + rts/idris_net.c rts/idris_net.h + rts/idris_opts.c + rts/idris_opts.h + rts/idris_rts.c + rts/idris_rts.h + rts/idris_stats.c + rts/idris_stats.h + rts/idris_stdfgn.c rts/idris_stdfgn.h + rts/mini-gmp.c + rts/mini-gmp.h rts/libtest.c Extra-source-files: @@ -66,6 +82,7 @@ rts/*.c rts/*.h + rts/arduino/*.c rts/windows/*.c rts/Makefile @@ -100,9 +117,6 @@ libs/effects/Effect/*.idr libs/effects/*.idr - llvm/*.c - llvm/Makefile - test/Makefile test/runtest.pl test/reg001/run @@ -253,6 +267,12 @@ test/reg051/run test/reg051/*.idr test/reg051/expected + test/reg052/run + test/reg052/*.idr + test/reg052/expected + test/reg053/run + test/reg053/*.idr + test/reg053/expected test/basic001/run test/basic001/*.idr @@ -285,6 +305,9 @@ test/basic010/run test/basic010/*.idr test/basic010/expected + test/basic011/run + test/basic011/*.idr + test/basic011/expected test/buffer001-disabled/*.idr test/buffer001-disabled/run @@ -391,6 +414,14 @@ test/interactive004/input test/interactive004/*.idr test/interactive004/expected + test/interactive005/run + test/interactive005/input + test/interactive005/*.idr + test/interactive005/expected + test/interactive006/run + test/interactive006/input + test/interactive006/*.idr + test/interactive006/expected test/io001/run test/io001/*.idr @@ -521,11 +552,6 @@ type: git location: git://github.com/idris-lang/Idris-dev.git -Flag LLVM - Description: Build the LLVM backend - Default: False - manual: True - Flag FFI Description: Build support for libffi Default: False @@ -578,6 +604,7 @@ , Idris.Elab.Class , Idris.Elab.Instance , Idris.Elab.Provider + , Idris.Elab.Transform , Idris.Elab.Value , Idris.AbsSyntax @@ -631,17 +658,12 @@ , IRTS.Bytecode , IRTS.CodegenC , IRTS.CodegenCommon - , IRTS.CodegenJava , IRTS.CodegenJavaScript , IRTS.JavaScript.AST , IRTS.Compiler , IRTS.Defunctionalise , IRTS.DumpBC , IRTS.Inliner - , IRTS.Java.ASTBuilding - , IRTS.Java.JTypes - , IRTS.Java.Mangling - , IRTS.Java.Pom , IRTS.Lang , IRTS.LangOpts , IRTS.Simplified @@ -650,10 +672,10 @@ , Pkg.Package , Util.DynamicLinker , Util.ScreenSize + , Util.System Other-modules: Util.Pretty - , Util.System , Util.Net , Util.Zlib @@ -664,42 +686,39 @@ , Version_idris Build-depends: base >=4 && <5 - , Cabal - , annotated-wl-pprint >= 0.5.3 - , ansi-terminal - , ansi-wl-pprint - , base64-bytestring - , binary - , blaze-html >= 0.6.1.3 + , annotated-wl-pprint >= 0.5.3 && < 0.6 + , ansi-terminal < 0.7 + , ansi-wl-pprint < 0.7 + , base64-bytestring < 1.1 + , binary >= 0.7 && < 0.8 + , blaze-html >= 0.6.1.3 && < 0.8 , blaze-markup >= 0.5.2.1 && < 0.7.0.0 - , bytestring - , cheapskate - , containers >= 0.5 - , directory - , directory >= 1.2 - , filepath - , fingertree >= 0.1 - , haskeline >= 0.7 - , language-java >= 0.2.6 - , lens >= 4.1.1 - , mtl + , bytestring < 0.11 + , cheapskate < 0.2 + , containers >= 0.5 && < 0.6 + , deepseq < 1.4 + , directory >= 1.2 && < 1.3 + , filepath < 1.4 + , fingertree >= 0.1 && < 0.2 + , haskeline >= 0.7 && < 0.8 + , lens >= 4.1.1 && < 4.5 + , mtl < 2.3 + , network < 2.7 + , optparse-applicative >= 0.11 && < 0.12 , parsers >= 0.9 && < 0.13 - , pretty - , process - , split - , text - , time >= 1.4 - , transformers - , trifecta >= 1.1 - , unordered-containers - , utf8-string - , vector - , vector-binary-instances - , network - , xml - , deepseq - , zlib - , optparse-applicative >= 0.10 + , pretty < 1.2 + , process < 1.3 + , split < 0.3 + , text < 1.3 + , time >= 1.4 && < 1.6 + , transformers < 0.5 + , trifecta >= 1.1 && < 1.6 + , unordered-containers < 0.3 + , utf8-string < 0.4 + , vector < 0.11 + , vector-binary-instances < 0.3 + , xml < 1.4 + , zlib < 0.6 Extensions: MultiParamTypeClasses , DeriveFoldable , DeriveTraversable @@ -713,34 +732,27 @@ if os(linux) cpp-options: -DLINUX - build-depends: unix + build-depends: unix < 2.8 if os(freebsd) cpp-options: -DFREEBSD - build-depends: unix + build-depends: unix < 2.8 -- if os(dragonfly) -- cpp-options: -DDRAGONFLY --- build-depends: unix +-- build-depends: unix < 2.8 if os(darwin) cpp-options: -DMACOSX - build-depends: unix + build-depends: unix < 2.8 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: Win32 < 2.4 if flag(FFI) - build-depends: libffi + build-depends: libffi < 0.2 cpp-options: -DIDRIS_FFI if flag(GMP) - build-depends: libffi + build-depends: libffi < 0.2 cpp-options: -DIDRIS_GMP if flag(curses) - build-depends: hscurses + build-depends: hscurses < 1.5 cpp-options: -DCURSES if flag(freestanding) other-modules: Target_idris @@ -759,18 +771,18 @@ ghc-prof-options: -auto-all -caf-all ghc-options: -threaded -rtsopts -funbox-strict-fields -Executable idris-c - Main-is: Main.hs - hs-source-dirs: codegen/idris-c - - Build-depends: idris - , base - , filepath - , haskeline >= 0.7 - , transformers - - ghc-prof-options: -auto-all -caf-all - ghc-options: -threaded -rtsopts -funbox-strict-fields +-- Executable idris-c +-- Main-is: Main.hs +-- hs-source-dirs: codegen/idris-c +-- +-- Build-depends: idris +-- , base +-- , filepath +-- , haskeline >= 0.7 +-- , transformers +-- +-- ghc-prof-options: -auto-all -caf-all +-- ghc-options: -threaded -rtsopts -funbox-strict-fields Executable idris-javascript Main-is: Main.hs diff --git a/jsrts/Runtime-common.js b/jsrts/Runtime-common.js --- a/jsrts/Runtime-common.js +++ b/jsrts/Runtime-common.js @@ -16,6 +16,14 @@ var i$ret; var i$callstack; +var i$Int = {}; +var i$String = {}; +var i$Integer = {}; +var i$Float = {}; +var i$Char = {}; +var i$Ptr = {}; +var i$Forgot = {}; + /** @constructor */ var i$CON = function(tag,args,app,ev) { this.tag = tag; @@ -59,7 +67,7 @@ var res = fid; - for(var i = 0; i < arguments.length; ++i) { + for(var i = 0; i < (arguments.length ? arguments.length : 1); ++i) { while (res instanceof i$CON) { i$valstack_top += 1; i$valstack[i$valstack_top] = res; diff --git a/libs/base/Control/Isomorphism.idr b/libs/base/Control/Isomorphism.idr --- a/libs/base/Control/Isomorphism.idr +++ b/libs/base/Control/Isomorphism.idr @@ -14,9 +14,9 @@ -- Isomorphism properties -||| Isomorphism is reflexive +||| Isomorphism is Reflexive isoRefl : Iso a a -isoRefl = MkIso id id (\x => refl) (\x => refl) +isoRefl = MkIso id id (\x => Refl) (\x => Refl) ||| Isomorphism is transitive isoTrans : Iso a b -> Iso b c -> Iso a c @@ -43,8 +43,8 @@ swap (Left x) = Right x swap (Right x) = Left x swapSwap : (e : Either a' b') -> swap (swap e) = e - swapSwap (Left x) = refl - swapSwap (Right x) = refl + swapSwap (Left x) = Refl + swapSwap (Right x) = Refl ||| Disjunction is associative eitherAssoc : Iso (Either (Either a b) c) (Either a (Either b c)) @@ -60,31 +60,31 @@ eitherAssoc2 (Right (Right x)) = Right x ok1 : (x : Either a (Either b c)) -> eitherAssoc1 (eitherAssoc2 x) = x - ok1 (Left x) = refl - ok1 (Right (Left x)) = refl - ok1 (Right (Right x)) = refl + ok1 (Left x) = Refl + ok1 (Right (Left x)) = Refl + ok1 (Right (Right x)) = Refl ok2 : (x : Either (Either a b) c) -> eitherAssoc2 (eitherAssoc1 x) = x - ok2 (Left (Left x)) = refl - ok2 (Left (Right x)) = refl - ok2 (Right x) = refl + ok2 (Left (Left x)) = Refl + ok2 (Left (Right x)) = Refl + ok2 (Right x) = Refl ||| Disjunction with false is a no-op -eitherBotLeft : Iso (Either _|_ a) a +eitherBotLeft : Iso (Either Void a) a eitherBotLeft = MkIso to from ok1 ok2 - where to : Either _|_ a -> a - to (Left x) = FalseElim x + where to : Either Void a -> a + to (Left x) = void x to (Right x) = x - from : a -> Either _|_ a + from : a -> Either Void a from = Right ok1 : (x : a) -> to (from x) = x - ok1 x = refl - ok2 : (x : Either _|_ a) -> from (to x) = x - ok2 (Left x) = FalseElim x - ok2 (Right x) = refl + ok1 x = Refl + ok2 : (x : Either Void a) -> from (to x) = x + ok2 (Left x) = void x + ok2 (Right x) = Refl ||| Disjunction with false is a no-op -eitherBotRight : Iso (Either a _|_) a +eitherBotRight : Iso (Either a Void) a eitherBotRight = isoTrans eitherComm eitherBotLeft ||| Isomorphism is a congruence with regards to disjunction @@ -119,7 +119,7 @@ swap (x, y) = (y, x) swapSwap : (x : (a', b')) -> swap (swap x) = x - swapSwap (x, y) = refl + swapSwap (x, y) = Refl ||| Conjunction is associative pairAssoc : Iso (a, (b, c)) ((a, b), c) @@ -130,26 +130,26 @@ from : ((a, b), c) -> (a, (b, c)) from ((x, y), z) = (x, (y, z)) ok1 : (x : ((a, b), c)) -> to (from x) = x - ok1 ((x, y), z) = refl + ok1 ((x, y), z) = Refl ok2 : (x : (a, (b, c))) -> from (to x) = x - ok2 (x, (y, z)) = refl + ok2 (x, (y, z)) = Refl ||| Conjunction with truth is a no-op pairUnitRight : Iso (a, ()) a -pairUnitRight = MkIso fst (\x => (x, ())) (\x => refl) ok +pairUnitRight = MkIso fst (\x => (x, ())) (\x => Refl) ok where ok : (x : (a, ())) -> (fst x, ()) = x - ok (x, ()) = refl + ok (x, ()) = Refl ||| Conjunction with truth is a no-op pairUnitLeft : Iso ((), a) a pairUnitLeft = isoTrans pairComm pairUnitRight ||| Conjunction preserves falsehood -pairBotLeft : Iso (_|_, a) _|_ -pairBotLeft = MkIso fst FalseElim (\x => FalseElim x) (\y => FalseElim (fst y)) +pairBotLeft : Iso (Void, a) Void +pairBotLeft = MkIso fst void (\x => void x) (\y => void (fst y)) ||| Conjunction preserves falsehood -pairBotRight : Iso (a, _|_) _|_ +pairBotRight : Iso (a, Void) Void pairBotRight = isoTrans pairComm pairBotLeft ||| Isomorphism is a congruence with regards to conjunction @@ -165,11 +165,11 @@ iso1 : (x : (a', b')) -> to'' (from'' x) = x iso1 (x, y) = rewrite toFrom x in rewrite toFrom' y in - refl + Refl iso2 : (x : (a, b)) -> from'' (to'' x) = x iso2 (x, y) = rewrite fromTo x in rewrite fromTo' y in - refl + Refl ||| Isomorphism is a congruence with regards to conjunction on the left pairCongLeft : Iso a a' -> Iso (a, b) (a', b) @@ -190,11 +190,11 @@ from (Left (x, y)) = (Left x, y) from (Right (x, y)) = (Right x, y) toFrom : (x : Either (a, c) (b, c)) -> to (from x) = x - toFrom (Left (x, y)) = refl - toFrom (Right (x, y)) = refl + toFrom (Left (x, y)) = Refl + toFrom (Right (x, y)) = Refl fromTo : (x : (Either a b, c)) -> from (to x) = x - fromTo (Left x, y) = refl - fromTo (Right x, y) = refl + fromTo (Left x, y) = Refl + fromTo (Right x, y) = Refl ||| Products distribute over sums distribRight : Iso (a, Either b c) (Either (a, b) (a, c)) @@ -217,10 +217,10 @@ maybeCong : Iso a b -> Iso (Maybe a) (Maybe b) maybeCong {a} {b} (MkIso to from toFrom fromTo) = MkIso (map to) (map from) ok1 ok2 where ok1 : (y : Maybe b) -> map to (map from y) = y - ok1 Nothing = refl + ok1 Nothing = Refl ok1 (Just x) = (Just (to (from x))) ={ cong (toFrom x) }= (Just x) QED ok2 : (x : Maybe a) -> map from (map to x) = x - ok2 Nothing = refl + ok2 Nothing = Refl ok2 (Just x) = (Just (from (to x))) ={ cong (fromTo x) }= (Just x) QED ||| `Maybe a` is the same as `Either a ()` @@ -233,16 +233,16 @@ from (Left x) = Just x from (Right ()) = Nothing iso1 : (x : Either a ()) -> to (from x) = x - iso1 (Left x) = refl - iso1 (Right ()) = refl + iso1 (Left x) = Refl + iso1 (Right ()) = Refl iso2 : (y : Maybe a) -> from (to y) = y - iso2 Nothing = refl - iso2 (Just x) = refl + iso2 Nothing = Refl + iso2 (Just x) = Refl ||| Maybe of void is just unit -maybeVoidUnit : Iso (Maybe _|_) () -maybeVoidUnit = (Maybe _|_) ={ maybeEither }= - (Either _|_ ()) ={ eitherBotLeft }= +maybeVoidUnit : Iso (Maybe Void) () +maybeVoidUnit = (Maybe Void) ={ maybeEither }= + (Either Void ()) ={ eitherBotLeft }= () QED eitherMaybeLeftMaybe : Iso (Either (Maybe a) b) (Maybe (Either a b)) @@ -268,28 +268,28 @@ maybeIsoS : Iso (Maybe (Fin n)) (Fin (S n)) maybeIsoS = MkIso forth back fb bf where forth : Maybe (Fin n) -> Fin (S n) - forth Nothing = fZ - forth (Just x) = fS x + forth Nothing = FZ + forth (Just x) = FS x back : Fin (S n) -> Maybe (Fin n) - back fZ = Nothing - back (fS x) = Just x + back FZ = Nothing + back (FS x) = Just x bf : (x : Maybe (Fin n)) -> back (forth x) = x - bf Nothing = refl - bf (Just x) = refl + bf Nothing = Refl + bf (Just x) = Refl fb : (y : Fin (S n)) -> forth (back y) = y - fb fZ = refl - fb (fS x) = refl + fb FZ = Refl + fb (FS x) = Refl -finZeroBot : Iso (Fin 0) _|_ -finZeroBot = MkIso (\x => FalseElim (uninhabited x)) - (\x => FalseElim x) - (\x => FalseElim x) - (\x => FalseElim (uninhabited x)) +finZeroBot : Iso (Fin 0) Void +finZeroBot = MkIso (\x => void (uninhabited x)) + (\x => void x) + (\x => void x) + (\x => void (uninhabited x)) eitherFinPlus : Iso (Either (Fin m) (Fin n)) (Fin (m + n)) eitherFinPlus {m = Z} {n=n} = (Either (Fin 0) (Fin n)) ={ eitherCongLeft finZeroBot }= - (Either _|_ (Fin n)) ={ eitherBotLeft }= + (Either Void (Fin n)) ={ eitherBotLeft }= (Fin n) QED eitherFinPlus {m = S k} {n=n} = (Either (Fin (S k)) (Fin n)) ={ eitherCongLeft (isoSym maybeIsoS) }= @@ -302,8 +302,8 @@ finPairTimes : Iso (Fin m, Fin n) (Fin (m * n)) finPairTimes {m = Z} {n=n} = (Fin Z, Fin n) ={ pairCongLeft finZeroBot }= - (_|_, Fin n) ={ pairBotLeft }= - _|_ ={ isoSym finZeroBot }= + (Void, Fin n) ={ pairBotLeft }= + Void ={ isoSym finZeroBot }= (Fin Z) QED finPairTimes {m = S k} {n=n} = (Fin (S k), Fin n) ={ pairCongLeft (isoSym maybeIsoS) }= diff --git a/libs/base/Control/Isomorphism/Primitives.idr b/libs/base/Control/Isomorphism/Primitives.idr --- a/libs/base/Control/Isomorphism/Primitives.idr +++ b/libs/base/Control/Isomorphism/Primitives.idr @@ -20,16 +20,16 @@ fromZZ n = cast n toFromZZ : (n : Integer) -> fromZZ (toZZ n) = n - toFromZZ n = really_believe_me {a = n=n} {b = fromZZ (toZZ n) = n} refl + toFromZZ n = really_believe_me {a = n=n} {b = fromZZ (toZZ n) = n} Refl fromToZZ : (n : ZZ) -> toZZ (fromZZ n) = n - fromToZZ n = really_believe_me {a = n=n} {b = toZZ (fromZZ n) = n} refl + fromToZZ n = really_believe_me {a = n=n} {b = toZZ (fromZZ n) = n} Refl packUnpackIso : Iso (List Char) String packUnpackIso = MkIso pack unpack - (\str => really_believe_me {a = str=str} {b = pack (unpack str) = str} refl) - (\cs => really_believe_me {a = cs=cs} {b = unpack (pack cs) = cs} refl) + (\str => really_believe_me {a = str=str} {b = pack (unpack str) = str} Refl) + (\cs => really_believe_me {a = cs=cs} {b = unpack (pack cs) = cs} Refl) diff --git a/libs/base/Control/Monad/RWS.idr b/libs/base/Control/Monad/RWS.idr --- a/libs/base/Control/Monad/RWS.idr +++ b/libs/base/Control/Monad/RWS.idr @@ -16,35 +16,35 @@ (runRWST : r -> s -> m (a, s, w)) -> RWST r w s m a instance Monad m => Functor (RWST r w s m) where - map f (MkRWST m) = MkRWST $ \r => \s => do (a, s', w) <- m r s - return (f a, s', w) + map f (MkRWST m) = MkRWST $ \r,s => do (a, s', w) <- m r s + return (f a, s', w) instance (Monoid w, Monad m) => Applicative (RWST r w s m) where - pure a = MkRWST $ \_ => \s => return (a, s, neutral) - (MkRWST f) <$> (MkRWST v) = MkRWST $ \r => \s => do (a, s', w) <- v r s - (fn, ss, w') <- f r s - return (fn a, ss, w <+> w) + pure a = MkRWST $ \_,s => return (a, s, neutral) + (MkRWST f) <$> (MkRWST v) = MkRWST $ \r,s => do (a, s', w) <- v r s + (fn, ss, w') <- f r s + return (fn a, ss, w <+> w) instance (Monoid w, Monad m) => Monad (RWST r w s m) where - (MkRWST m) >>= k = MkRWST $ \r => \s => do (a, s', w) <- m r s - let MkRWST ka = k a - (b, ss, w') <- ka r s' - return (b, ss, w <+> w') + (MkRWST m) >>= k = MkRWST $ \r,s => do (a, s', w) <- m r s + let MkRWST ka = k a + (b, ss, w') <- ka r s' + return (b, ss, w <+> w') instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where - ask = MkRWST $ \r => \s => return (r, s, neutral) - local f (MkRWST m) = MkRWST $ \r => \s => m (f r) s + ask = MkRWST $ \r,s => return (r, s, neutral) + local f (MkRWST m) = MkRWST $ \r,s => m (f r) s instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where - tell w = MkRWST $ \_ => \s => return ((), s, w) - listen (MkRWST m) = MkRWST $ \r => \s => do (a, s', w) <- m r s - return ((a, w), s', w) - pass (MkRWST m) = MkRWST $ \r => \s => do ((a, f), s', w) <- m r s - return (a, s', f w) + tell w = MkRWST $ \_,s => return ((), s, w) + listen (MkRWST m) = MkRWST $ \r,s => do (a, s', w) <- m r s + return ((a, w), s', w) + pass (MkRWST m) = MkRWST $ \r,s => do ((a, f), s', w) <- m r s + return (a, s', f w) instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where - get = MkRWST $ \_ => \s => return (s, s, neutral) - put s = MkRWST $ \_ => \_ => return ((), s, neutral) + get = MkRWST $ \_,s => return (s, s, neutral) + put s = MkRWST $ \_,_ => return ((), s, neutral) instance (Monoid w, Monad m) => MonadRWS r w s (RWST r w s m) where {} diff --git a/libs/base/Data/Bits.idr b/libs/base/Data/Bits.idr --- a/libs/base/Data/Bits.idr +++ b/libs/base/Data/Bits.idr @@ -437,8 +437,8 @@ where %assert_total helper : Fin (S n) -> Bits n -> List Char - helper fZ _ = [] - helper (fS x) b = (if getBit x b then '1' else '0') :: helper (weaken x) b + helper FZ _ = [] + helper (FS x) b = (if getBit x b then '1' else '0') :: helper (weaken x) b instance Show (Bits n) where show = bitsToStr diff --git a/libs/base/Data/BoundedList.idr b/libs/base/Data/BoundedList.idr --- a/libs/base/Data/BoundedList.idr +++ b/libs/base/Data/BoundedList.idr @@ -10,8 +10,8 @@ ||| Compute the length of a list. length : BoundedList n a -> Fin (S n) -length [] = fZ -length (x :: xs) = fS (length xs) +length [] = FZ +length (x :: xs) = FS (length xs) -------------------------------------------------------------------------------- -- Indexing into bounded lists @@ -19,8 +19,8 @@ index : Fin (S n) -> BoundedList n a -> Maybe a index _ [] = Nothing -index fZ (x :: _) = Just x -index (fS f) (_ :: xs) = index f xs +index FZ (x :: _) = Just x +index (FS f) (_ :: xs) = index f xs -------------------------------------------------------------------------------- -- Adjusting bounds @@ -90,5 +90,5 @@ -------------------------------------------------------------------------------- zeroBoundIsEmpty : (xs : BoundedList 0 a) -> xs = the (BoundedList 0 a) [] -zeroBoundIsEmpty [] = refl +zeroBoundIsEmpty [] = Refl zeroBoundIsEmpty (_ :: _) impossible diff --git a/libs/base/Data/Buffer.idr b/libs/base/Data/Buffer.idr --- a/libs/base/Data/Buffer.idr +++ b/libs/base/Data/Buffer.idr @@ -33,8 +33,8 @@ bitsFromNat (S k) = 1 + bitsFromNat k bitsFromFin : Fin n -> Bits64 -bitsFromFin fZ = 0 -bitsFromFin (fS k) = 1 + bitsFromFin k +bitsFromFin FZ = 0 +bitsFromFin (FS k) = 1 + bitsFromFin k ||| Allocate an empty Buffer. The size hint can be used to avoid ||| unnecessary reallocations and copies under the hood if the diff --git a/libs/base/Data/HVect.idr b/libs/base/Data/HVect.idr --- a/libs/base/Data/HVect.idr +++ b/libs/base/Data/HVect.idr @@ -13,22 +13,22 @@ ||| Extract an element from an HVect index : (i : Fin k) -> HVect ts -> index i ts -index fZ (x::xs) = x -index (fS j) (x::xs) = index j xs +index FZ (x::xs) = x +index (FS j) (x::xs) = index j xs deleteAt : (i : Fin (S l)) -> HVect us -> HVect (deleteAt i us) -deleteAt fZ (x::xs) = xs -deleteAt {l = S m} (fS j) (x::xs) = x :: deleteAt j xs -deleteAt {l = Z} (fS j) (x::xs) = absurd j +deleteAt FZ (x::xs) = xs +deleteAt {l = S m} (FS j) (x::xs) = x :: deleteAt j xs +deleteAt {l = Z} (FS j) (x::xs) = absurd j deleteAt _ [] impossible replaceAt : (i : Fin k) -> t -> HVect ts -> HVect (replaceAt i t ts) -replaceAt fZ y (x::xs) = y::xs -replaceAt (fS j) y (x::xs) = x :: replaceAt j y xs +replaceAt FZ y (x::xs) = y::xs +replaceAt (FS j) y (x::xs) = x :: replaceAt j y xs updateAt : (i : Fin k) -> (index i ts -> t) -> HVect ts -> HVect (replaceAt i t ts) -updateAt fZ f (x::xs) = f x :: xs -updateAt (fS j) f (x::xs) = x :: updateAt j f xs +updateAt FZ f (x::xs) = f x :: xs +updateAt (FS j) f (x::xs) = x :: updateAt j f xs ||| Append two `HVect`s. (++) : HVect ts -> HVect us -> HVect (ts ++ us) diff --git a/libs/base/Data/Hash.idr b/libs/base/Data/Hash.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Hash.idr @@ -0,0 +1,85 @@ +module Data.Hash + +%access public +%default total + +{- A general purpose Hashing library (not cryptographic) + + The core hash is djb2, which is very fast but does not have the best distribution + Source: http://www.cse.yorku.ca/~oz/hash.html + + The salted version and the magic salt are copied from Haskell's bloomfilter library + Source: https://hackage.haskell.org/package/bloomfilter-2.0.0.0/docs/src/Data-BloomFilter-Hash.html#Hashable +-} + +||| A type that can be hashed +class Hashable a where + saltedHash64 : a -> Bits64 -> Bits64 -- value to hash, salt, hash + +||| Computes a non cryptographic hash +hash : Hashable a => a -> Bits64 +hash x = saltedHash64 x 0x16fc397cf62f64d3 + +||| Given a user provided salt, computes a non cryptographic hash. +||| This version is meant to mitigate hash-flooding DoS attacks. +saltedHash : Hashable a => Bits64 -> a -> Bits64 +saltedHash salt x = saltedHash64 x salt + + +||| Nth byte of a Bits64 +private +byte : Bits64 -> Bits64 -> Bits64 +byte n w = prim__lshrB64 (prim__andB64 mask w) offset + where offset = 8*n + mask = prim__shlB64 0xff (the Bits64 offset) + +||| Modulo of an integer, downsized to a Bits64 +private +mod64 : Integer -> Bits64 +mod64 i = assert_total $ prim__truncBigInt_B64 (abs i `mod` 0xffffffffffffffff) + +instance Hashable Bits64 where + saltedHash64 w salt = foldr (\b,acc => (acc `prim__shlB64` 10) + acc + b) + salt + [byte (fromInteger n) w | n <- [7,6..0]] -- djb2 hash function. Not meant for crypto + +instance Hashable Integer where + saltedHash64 i = saltedHash64 (mod64 i) + +instance Hashable () where + saltedHash64 _ salt = salt + +instance Hashable Bool where + saltedHash64 True = saltedHash64 (the Bits64 1) + saltedHash64 False = saltedHash64 (the Bits64 0) + +instance Hashable Int where + saltedHash64 w = saltedHash64 (prim__zextInt_B64 w) + +instance Hashable Char where + saltedHash64 w = saltedHash64 (the Int (cast w)) + +instance Hashable Bits8 where + saltedHash64 w = saltedHash64 (prim__zextB8_B64 w) + +instance Hashable Bits16 where + saltedHash64 w = saltedHash64 (prim__zextB16_B64 w) + +instance Hashable Bits32 where + saltedHash64 w = saltedHash64 (prim__zextB32_B64 w) + +instance Hashable a => Hashable (Maybe a) where + saltedHash64 Nothing salt = salt + saltedHash64 (Just k) salt = saltedHash64 k salt + +instance (Hashable a, Hashable b) => Hashable (a, b) where + saltedHash64 (a,b) salt = saltedHash64 b (saltedHash64 a salt) + +instance Hashable a => Hashable (List a) where + saltedHash64 l salt = foldr (\c,acc => saltedHash64 c acc) salt l + +instance Hashable a => Hashable (Vect n a) where + saltedHash64 l salt = foldr (\c,acc => saltedHash64 c acc) salt l + +instance Hashable String where + saltedHash64 s = saltedHash64 (unpack s) diff --git a/libs/base/Data/Heap.idr b/libs/base/Data/Heap.idr --- a/libs/base/Data/Heap.idr +++ b/libs/base/Data/Heap.idr @@ -83,11 +83,11 @@ -------------------------------------------------------------------------------- findMinimum : (h : MaxiphobicHeap a) -> (isEmpty h = False) -> a -findMinimum Empty refl impossible +findMinimum Empty Refl impossible findMinimum (Node s l e r) p = e deleteMinimum : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> MaxiphobicHeap a -deleteMinimum Empty refl impossible +deleteMinimum Empty Refl impossible deleteMinimum (Node s l e r) p = merge l r -------------------------------------------------------------------------------- @@ -96,7 +96,7 @@ toList : Ord a => MaxiphobicHeap a -> List a toList Empty = [] -toList (Node s l e r) = toList' (Node s l e r) refl +toList (Node s l e r) = toList' (Node s l e r) Refl where %assert_total -- relies on deleteMinimum making heap smaller toList' : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> List a @@ -135,28 +135,28 @@ -- Properties -------------------------------------------------------------------------------- -total absurdBoolDischarge : False = True -> _|_ +total absurdBoolDischarge : False = True -> Void absurdBoolDischarge p = replace {P = disjointTy} p () where total disjointTy : Bool -> Type disjointTy False = () - disjointTy True = _|_ + disjointTy True = Void total isEmptySizeZero : (h : MaxiphobicHeap a) -> (isEmpty h = True) -> size h = Z -isEmptySizeZero Empty p = refl +isEmptySizeZero Empty p = Refl isEmptySizeZero (Node s l e r) p = ?isEmptySizeZeroNodeAbsurd total emptyHeapValid : Ord a => isValidHeap empty = True -emptyHeapValid = refl +emptyHeapValid = Refl total singletonHeapValid : Ord a => (e : a) -> isValidHeap $ singleton e = True -singletonHeapValid e = refl +singletonHeapValid e = Refl {- total mergePreservesValidHeaps : Ord a => (left : MaxiphobicHeap a) -> (right : MaxiphobicHeap a) -> (leftValid : isValidHeap left = True) -> (rightValid : isValidHeap right = True) -> isValidHeap $ merge left right = True -mergePreservesValidHeaps Empty Empty lp rp = refl +mergePreservesValidHeaps Empty Empty lp rp = Refl mergePreservesValidHeaps Empty (Node rs rl re rr) lp rp = rp mergePreservesValidHeaps (Node ls ll le lr) Empty lp rp = lp mergePreservesValidHeaps (Node ls ll le lr) (Node rs rl re rr) lp rp = @@ -169,7 +169,7 @@ isEmptySizeZeroNodeAbsurd = proof { intros; - refine FalseElim; + refine void; refine absurdBoolDischarge; exact p; } diff --git a/libs/base/Data/List.idr b/libs/base/Data/List.idr --- a/libs/base/Data/List.idr +++ b/libs/base/Data/List.idr @@ -2,9 +2,17 @@ %access public -||| A proof that some element is found in a list +||| A proof that some element is found in a list. +||| +||| Example: `the (Elem "bar" ["foo", "bar", "baz"]) (tactics { search })` data Elem : a -> List a -> Type where + ||| A proof that the element is at the front of the list. + ||| + ||| Example: `the (Elem "a" ["a", "b"]) Here` Here : Elem x (x :: xs) + ||| A proof that the element is after the front of the list + ||| + ||| Example: `the (Elem "b" ["a", "b"]) (There Here)` There : Elem x xs -> Elem x (y :: xs) instance Uninhabited (Elem {a} x []) where @@ -18,13 +26,13 @@ isElem : DecEq a => (x : a) -> (xs : List a) -> Dec (Elem x xs) isElem x [] = No absurd isElem x (y :: xs) with (decEq x y) - isElem x (x :: xs) | (Yes refl) = Yes Here + isElem x (x :: xs) | (Yes Refl) = Yes Here isElem x (y :: xs) | (No contra) with (isElem x xs) isElem x (y :: xs) | (No contra) | (Yes prf) = Yes (There prf) isElem x (y :: xs) | (No contra) | (No f) = No (mkNo contra f) where mkNo : {xs' : List a} -> - ((x' = y') -> _|_) -> (Elem x' xs' -> _|_) -> - Elem x' (y' :: xs') -> _|_ - mkNo f g Here = f refl + ((x' = y') -> Void) -> (Elem x' xs' -> Void) -> + Elem x' (y' :: xs') -> Void + mkNo f g Here = f Refl mkNo f g (There x) = g x diff --git a/libs/base/Data/Vect.idr b/libs/base/Data/Vect.idr --- a/libs/base/Data/Vect.idr +++ b/libs/base/Data/Vect.idr @@ -15,19 +15,19 @@ There : Elem x xs -> Elem x (y::xs) ||| Nothing can be in an empty Vect -noEmptyElem : {x : a} -> Elem x [] -> _|_ +noEmptyElem : {x : a} -> Elem x [] -> Void noEmptyElem Here impossible ||| An item not in the head and not in the tail is not in the Vect at all neitherHereNorThere : {x, y : a} -> {xs : Vect n a} -> Not (x = y) -> Not (Elem x xs) -> Not (Elem x (y :: xs)) -neitherHereNorThere xneqy xninxs Here = xneqy refl +neitherHereNorThere xneqy xninxs Here = xneqy Refl neitherHereNorThere xneqy xninxs (There xinxs) = xninxs xinxs ||| A decision procedure for Elem isElem : DecEq a => (x : a) -> (xs : Vect n a) -> Dec (Elem x xs) isElem x [] = No noEmptyElem isElem x (y :: xs) with (decEq x y) - isElem x (x :: xs) | (Yes refl) = Yes Here + isElem x (x :: xs) | (Yes Refl) = Yes Here isElem x (y :: xs) | (No xneqy) with (isElem x xs) isElem x (y :: xs) | (No xneqy) | (Yes xinxs) = Yes (There xinxs) isElem x (y :: xs) | (No xneqy) | (No xninxs) = No (neitherHereNorThere xneqy xninxs) diff --git a/libs/base/Data/Vect/Quantifiers.idr b/libs/base/Data/Vect/Quantifiers.idr --- a/libs/base/Data/Vect/Quantifiers.idr +++ b/libs/base/Data/Vect/Quantifiers.idr @@ -1,10 +1,16 @@ module Data.Vect.Quantifiers +||| A proof that some element of a vector satisfies some property +||| +||| @ P the property to be satsified data Any : (P : a -> Type) -> Vect n a -> Type where + ||| A proof that the satisfying element is the first one in the `Vect` Here : {P : a -> Type} -> {xs : Vect n a} -> P x -> Any P (x :: xs) + ||| A proof that the satsifying element is in the tail of the `Vect` There : {P : a -> Type} -> {xs : Vect n a} -> Any P xs -> Any P (x :: xs) -anyNilAbsurd : {P : a -> Type} -> Any P Nil -> _|_ +||| No element of an empty vector satisfies any property +anyNilAbsurd : {P : a -> Type} -> Any P Nil -> Void anyNilAbsurd (Here _) impossible anyNilAbsurd (There _) impossible @@ -15,7 +21,13 @@ anyElim _ f (Here p) = f p anyElim f _ (There p) = f p -any : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a) -> Dec (Any P xs) +||| Given a decision procedure for a property, determine if an element of a +||| vector satisfies it. +||| +||| @ P the property to be satisfied +||| @ dec the decision procedure +||| @ xs the vector to examine +any : {P : a -> Type} -> (dec : (x : a) -> Dec (P x)) -> (xs : Vect n a) -> Dec (Any P xs) any _ Nil = No anyNilAbsurd any p (x::xs) with (p x) | Yes prf = Yes (Here prf) @@ -24,23 +36,33 @@ Yes prf' => Yes (There prf') No prf' => No (anyElim prf' prf) +||| A proof that all elements of a vector satisfy a property. It is a list of +||| proofs, corresponding element-wise to the `Vect`. data All : (P : a -> Type) -> Vect n a -> Type where Nil : {P : a -> Type} -> All P Nil (::) : {P : a -> Type} -> {xs : Vect n a} -> P x -> All P xs -> All P (x :: xs) +||| If there does not exist an element that satifies the property, then it is +||| the case that all elements do not satisfy. negAnyAll : {P : a -> Type} -> {xs : Vect n a} -> Not (Any P xs) -> All (\x => Not (P x)) xs negAnyAll {xs=Nil} _ = Nil negAnyAll {xs=(x::xs)} f = (\x => f (Here x)) :: negAnyAll (\x => f (There x)) -notAllHere : {P : a -> Type} -> {xs : Vect n a} -> Not (P x) -> All P (x :: xs) -> _|_ +notAllHere : {P : a -> Type} -> {xs : Vect n a} -> Not (P x) -> All P (x :: xs) -> Void notAllHere _ Nil impossible notAllHere np (p :: _) = np p -notAllThere : {P : a -> Type} -> {xs : Vect n a} -> Not (All P xs) -> All P (x :: xs) -> _|_ +notAllThere : {P : a -> Type} -> {xs : Vect n a} -> Not (All P xs) -> All P (x :: xs) -> Void notAllThere _ Nil impossible notAllThere np (_ :: ps) = np ps -all : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a) -> Dec (All P xs) +||| Given a decision procedure for a property, decide whether all elements of +||| a vector satisfy it. +||| +||| @ P the property +||| @ dec the decision procedure +||| @ xs the vector to examine +all : {P : a -> Type} -> (dec : (x : a) -> Dec (P x)) -> (xs : Vect n a) -> Dec (All P xs) all _ Nil = Yes Nil all d (x::xs) with (d x) | No prf = No (notAllHere prf) diff --git a/libs/base/Data/ZZ.idr b/libs/base/Data/ZZ.idr --- a/libs/base/Data/ZZ.idr +++ b/libs/base/Data/ZZ.idr @@ -7,14 +7,18 @@ %access public -||| An integer is either a positive nat or the negated successor of a nat. -||| Zero is arbitrarily chosen to be positive. +||| An integer is either a positive `Nat` or the negated successor of a `Nat`. +||| +||| For example, 3 is `Pos 3` and -2 is `NegS 1`. Zero is arbitrarily chosen +||| to be positive. +||| data ZZ = Pos Nat | NegS Nat instance Signed ZZ where sign (Pos _) = Plus sign (NegS _) = Minus +||| Take the absolute value of a `ZZ` absZ : ZZ -> Nat absZ (Pos n) = n absZ (NegS n) = S n @@ -23,28 +27,32 @@ show (Pos n) = show n show (NegS n) = "-" ++ show (S n) -negZ : ZZ -> ZZ -negZ (Pos Z) = Pos Z -negZ (Pos (S n)) = NegS n -negZ (NegS n) = Pos (S n) +instance Neg ZZ where + negate (Pos Z) = Pos Z + negate (Pos (S n)) = NegS n + negate (NegS n) = Pos (S n) negNat : Nat -> ZZ negNat Z = Pos Z negNat (S n) = NegS n + +||| Construct a `ZZ` as the difference of two `Nat`s minusNatZ : Nat -> Nat -> ZZ minusNatZ n Z = Pos n minusNatZ Z (S m) = NegS m minusNatZ (S n) (S m) = minusNatZ n m +||| Add two `ZZ`s. Consider using `(+) {a=ZZ}`. plusZ : ZZ -> ZZ -> ZZ plusZ (Pos n) (Pos m) = Pos (n + m) plusZ (NegS n) (NegS m) = NegS (S (n + m)) plusZ (Pos n) (NegS m) = minusNatZ n (S m) plusZ (NegS n) (Pos m) = minusNatZ m (S n) +||| Subtract two `ZZ`s. Consider using `(-) {a=ZZ}`. subZ : ZZ -> ZZ -> ZZ -subZ n m = plusZ n (negZ m) +subZ n m = plusZ n (negate m) instance Eq ZZ where (Pos n) == (Pos m) = n == m @@ -58,13 +66,14 @@ compare (Pos _) (NegS _) = GT compare (NegS _) (Pos _) = LT - +||| Multiply two `ZZ`s. Consider using `(*) {a=ZZ}`. multZ : ZZ -> ZZ -> ZZ multZ (Pos n) (Pos m) = Pos $ n * m multZ (NegS n) (NegS m) = Pos $ (S n) * (S m) multZ (NegS n) (Pos m) = negNat $ (S n) * m multZ (Pos n) (NegS m) = negNat $ n * (S m) +||| Convert an `Integer` to an inductive representation. fromInt : Integer -> ZZ fromInt n = if n < 0 then NegS $ fromInteger {a=Nat} ((-n) - 1) @@ -100,21 +109,21 @@ -> n * m = x -> (Pos n) * (Pos m) = Pos x natMultZMult n m x h = cong h -doubleNegElim : (z : ZZ) -> negZ (negZ z) = z -doubleNegElim (Pos Z) = refl -doubleNegElim (Pos (S n)) = refl -doubleNegElim (NegS Z) = refl -doubleNegElim (NegS (S n)) = refl +doubleNegElim : (z : ZZ) -> negate (negate z) = z +doubleNegElim (Pos Z) = Refl +doubleNegElim (Pos (S n)) = Refl +doubleNegElim (NegS Z) = Refl +doubleNegElim (NegS (S n)) = Refl -- Injectivity posInjective : Pos n = Pos m -> n = m -posInjective refl = refl +posInjective Refl = Refl negSInjective : NegS n = NegS m -> n = m -negSInjective refl = refl +negSInjective Refl = Refl -posNotNeg : Pos n = NegS m -> _|_ -posNotNeg refl impossible +posNotNeg : Pos n = NegS m -> Void +posNotNeg Refl impossible -- Decidable equality instance DecEq ZZ where @@ -129,16 +138,16 @@ -- Plus plusZeroLeftNeutralZ : (right : ZZ) -> 0 + right = right -plusZeroLeftNeutralZ (Pos n) = refl -plusZeroLeftNeutralZ (NegS n) = refl +plusZeroLeftNeutralZ (Pos n) = Refl +plusZeroLeftNeutralZ (NegS n) = Refl plusZeroRightNeutralZ : (left : ZZ) -> left + 0 = left plusZeroRightNeutralZ (Pos n) = cong $ plusZeroRightNeutral n -plusZeroRightNeutralZ (NegS n) = refl +plusZeroRightNeutralZ (NegS n) = Refl plusCommutativeZ : (left : ZZ) -> (right : ZZ) -> (left + right = right + left) plusCommutativeZ (Pos n) (Pos m) = cong $ plusCommutative n m -plusCommutativeZ (Pos n) (NegS m) = refl -plusCommutativeZ (NegS n) (Pos m) = refl +plusCommutativeZ (Pos n) (NegS m) = Refl +plusCommutativeZ (NegS n) (Pos m) = Refl plusCommutativeZ (NegS n) (NegS m) = cong {f=NegS} $ cong {f=S} $ plusCommutative n m diff --git a/libs/base/Decidable/Order.idr b/libs/base/Decidable/Order.idr --- a/libs/base/Decidable/Order.idr +++ b/libs/base/Decidable/Order.idr @@ -48,7 +48,7 @@ instance Preorder t ((=) {A = t} {B = t}) where transitive a b c = trans {a = a} {b = b} {c = c} - reflexive a = refl + reflexive a = Refl instance Equivalence t ((=) {A = t} {B = t}) where symmetric a b prf = sym prf @@ -60,99 +60,88 @@ -- Natural numbers -------------------------------------------------------------------------------- -data NatLTE : Nat -> Nat -> Type where - nEqn : NatLTE n n - nLTESm : NatLTE n m -> NatLTE n (S m) +total LTEIsTransitive : (m : Nat) -> (n : Nat) -> (o : Nat) -> + LTE m n -> LTE n o -> + LTE m o +LTEIsTransitive Z n o LTEZero nlteo = LTEZero +LTEIsTransitive (S m) (S n) (S o) (LTESucc mlten) (LTESucc nlteo) = LTESucc (LTEIsTransitive m n o mlten nlteo) -total NatLTEIsTransitive : (m : Nat) -> (n : Nat) -> (o : Nat) -> - NatLTE m n -> NatLTE n o -> - NatLTE m o -NatLTEIsTransitive m n n mLTEn (nEqn) = mLTEn -NatLTEIsTransitive m n (S o) mLTEn (nLTESm nLTEo) - = nLTESm (NatLTEIsTransitive m n o mLTEn nLTEo) +total LTEIsReflexive : (n : Nat) -> LTE n n +LTEIsReflexive Z = LTEZero +LTEIsReflexive (S n) = LTESucc (LTEIsReflexive n) -total NatLTEIsReflexive : (n : Nat) -> NatLTE n n -NatLTEIsReflexive _ = nEqn +instance Preorder Nat LTE where + transitive = LTEIsTransitive + reflexive = LTEIsReflexive -instance Preorder Nat NatLTE where - transitive = NatLTEIsTransitive - reflexive = NatLTEIsReflexive +total LTEIsAntisymmetric : (m : Nat) -> (n : Nat) -> + LTE m n -> LTE n m -> m = n +LTEIsAntisymmetric Z Z LTEZero LTEZero = Refl +LTEIsAntisymmetric (S n) (S m) (LTESucc mLTEn) (LTESucc nLTEm) with (LTEIsAntisymmetric n m mLTEn nLTEm) + LTEIsAntisymmetric (S n) (S n) (LTESucc mLTEn) (LTESucc nLTEm) | Refl = Refl -total NatLTEIsAntisymmetric : (m : Nat) -> (n : Nat) -> - NatLTE m n -> NatLTE n m -> m = n -NatLTEIsAntisymmetric n n nEqn nEqn = refl -NatLTEIsAntisymmetric n m nEqn (nLTESm _) impossible -NatLTEIsAntisymmetric n m (nLTESm _) nEqn impossible -NatLTEIsAntisymmetric n m (nLTESm _) (nLTESm _) impossible -instance Poset Nat NatLTE where - antisymmetric = NatLTEIsAntisymmetric +instance Poset Nat LTE where + antisymmetric = LTEIsAntisymmetric -total zeroNeverGreater : {n : Nat} -> NatLTE (S n) Z -> _|_ -zeroNeverGreater {n} (nLTESm _) impossible -zeroNeverGreater {n} nEqn impossible +total zeroNeverGreater : {n : Nat} -> LTE (S n) Z -> Void +zeroNeverGreater {n} LTEZero impossible +zeroNeverGreater {n} (LTESucc _) impossible -total zeroAlwaysSmaller : {n : Nat} -> NatLTE Z n -zeroAlwaysSmaller {n = Z } = nEqn -zeroAlwaysSmaller {n = S k} = nLTESm (zeroAlwaysSmaller {n = k}) +total zeroAlwaysSmaller : {n : Nat} -> LTE Z n +zeroAlwaysSmaller = LTEZero -total -nGTSm : {n : Nat} -> {m : Nat} -> (NatLTE n m -> _|_) -> NatLTE n (S m) -> _|_ -nGTSm disprf (nLTESm nLTEm) = FalseElim (disprf nLTEm) -nGTSm {n} {m} disprf (nEqn) impossible +total ltesuccinjective : {n : Nat} -> {m : Nat} -> (LTE n m -> Void) -> LTE (S n) (S m) -> Void +ltesuccinjective {n} {m} disprf (LTESucc nLTEm) = void (disprf nLTEm) +ltesuccinjective {n} {m} disprf LTEZero impossible -total -decideNatLTE : (n : Nat) -> (m : Nat) -> Dec (NatLTE n m) -decideNatLTE Z Z = Yes nEqn -decideNatLTE (S x) Z = No zeroNeverGreater -decideNatLTE x (S y) with (decEq x (S y)) - | Yes eq = rewrite eq in Yes nEqn - | No _ with (decideNatLTE x y) - | Yes nLTEm = Yes (nLTESm nLTEm) - | No nGTm = No (nGTSm nGTm) -instance Decidable [Nat,Nat] NatLTE where - decide = decideNatLTE +total decideLTE : (n : Nat) -> (m : Nat) -> Dec (LTE n m) +decideLTE Z y = Yes LTEZero +decideLTE (S x) Z = No zeroNeverGreater +decideLTE (S x) (S y) with (decEq (S x) (S y)) + | Yes eq = rewrite eq in Yes (reflexive x) + | No _ with (decideLTE x y) + | Yes nLTEm = Yes (LTESucc nLTEm) + | No nGTm = No (ltesuccinjective nGTm) -total -lte : (m : Nat) -> (n : Nat) -> Dec (NatLTE m n) -lte m n = decide {ts = [Nat,Nat]} {p = NatLTE} m n +instance Decidable [Nat,Nat] LTE where + decide = decideLTE total -shift : (m : Nat) -> (n : Nat) -> NatLTE m n -> NatLTE (S m) (S n) -shift Z Z _ = nEqn -shift Z (S Z) _ = nLTESm nEqn -shift Z (S (S j)) _ = nLTESm (shift Z (S j) zeroAlwaysSmaller) -shift (S k) Z prf = FalseElim (zeroNeverGreater prf) -shift (S k) (S k) nEqn = nEqn -shift (S k) (S j) (nLTESm prf) = nLTESm (shift (S k) j prf) +lte : (m : Nat) -> (n : Nat) -> Dec (LTE m n) +lte m n = decide {ts = [Nat,Nat]} {p = LTE} m n -instance Ordered Nat NatLTE where - order Z n = Left zeroAlwaysSmaller - order m Z = Right zeroAlwaysSmaller +total +shift : (m : Nat) -> (n : Nat) -> LTE m n -> LTE (S m) (S n) +shift m n mLTEn = LTESucc mLTEn + +instance Ordered Nat LTE where + order Z n = Left LTEZero + order m Z = Right LTEZero order (S k) (S j) with (order k j) order (S k) (S j) | Left prf = Left (shift k j prf) order (S k) (S j) | Right prf = Right (shift j k prf) --------------------------------------------------------------------------------- --- Finite numbers --------------------------------------------------------------------------------- +---------------------------------------------------------------------------------- +---- Finite numbers +---------------------------------------------------------------------------------- using (k : Nat) data FinLTE : Fin k -> Fin k -> Type where - FromNatPrf : {m : Fin k} -> {n : Fin k} -> NatLTE (finToNat m) (finToNat n) -> FinLTE m n + FromNatPrf : {m : Fin k} -> {n : Fin k} -> LTE (finToNat m) (finToNat n) -> FinLTE m n instance Preorder (Fin k) FinLTE where transitive m n o (FromNatPrf p1) (FromNatPrf p2) = - FromNatPrf (NatLTEIsTransitive (finToNat m) (finToNat n) (finToNat o) p1 p2) - reflexive n = FromNatPrf (NatLTEIsReflexive (finToNat n)) + FromNatPrf (LTEIsTransitive (finToNat m) (finToNat n) (finToNat o) p1 p2) + reflexive n = FromNatPrf (LTEIsReflexive (finToNat n)) instance Poset (Fin k) FinLTE where antisymmetric m n (FromNatPrf p1) (FromNatPrf p2) = - finToNatInjective m n (NatLTEIsAntisymmetric (finToNat m) (finToNat n) p1 p2) + finToNatInjective m n (LTEIsAntisymmetric (finToNat m) (finToNat n) p1 p2) instance Decidable [Fin k, Fin k] FinLTE where - decide m n with (decideNatLTE (finToNat m) (finToNat n)) + decide m n with (decideLTE (finToNat m) (finToNat n)) | Yes prf = Yes (FromNatPrf prf) | No disprf = No (\ (FromNatPrf prf) => disprf prf) diff --git a/libs/base/Language/Reflection.idr b/libs/base/Language/Reflection.idr --- a/libs/base/Language/Reflection.idr +++ b/libs/base/Language/Reflection.idr @@ -79,20 +79,22 @@ ||| Types of named references -data NameType = Bound - -- ^ reference which is just bound, e.g. by intro - | Ref - -- ^ reference to a variable - | DCon Int Int - -- ^ constructor with tag and number - | TCon Int Int - -- ^ type constructor with tag and number +data NameType = + ||| A reference which is just bound, e.g. by intro + Bound | + ||| A reference to a de Bruijn-indexed variable + Ref | + ||| Data constructor with tag and number + DCon Int Int | + ||| Type constructor with tag and number + TCon Int Int + %name NameType nt, nt' ||| Types annotations for bound variables in different ||| binding contexts data Binder a = Lam a - | Pi a a + | Pi a a | Let a a | NLet a a | Hole a diff --git a/libs/base/Network/Socket.idr b/libs/base/Network/Socket.idr --- a/libs/base/Network/Socket.idr +++ b/libs/base/Network/Socket.idr @@ -4,8 +4,8 @@ module IdrisNet.Socket %include C "idris_net.h" -%include C "sys/types.h" -%include C "sys/socket.h" +%include C "sys/types.h" +%include C "sys/socket.h" %include C "netdb.h" %access public @@ -16,12 +16,17 @@ class ToCode a where toCode : a -> Int --- Socket Families. --- The ones that people might actually use. We're not going to need US Government --- proprietary ones... -data SocketFamily = AF_UNSPEC -- Unspecified - | AF_INET -- IP / UDP etc. IPv4 - | AF_INET6 -- IP / UDP etc. IPv6 +||| Socket Families +||| +||| The ones that people might actually use. We're not going to need US +||| Government proprietary ones. +data SocketFamily = + ||| Unspecified + AF_UNSPEC | + ||| IP / UDP etc. IPv4 + AF_INET | + ||| IP / UDP etc. IPv6 + AF_INET6 instance Show SocketFamily where show AF_UNSPEC = "AF_UNSPEC" @@ -36,11 +41,16 @@ getSocketFamily : Int -> Maybe SocketFamily getSocketFamily i = Prelude.List.lookup i [(0, AF_UNSPEC), (2, AF_INET), (10, AF_INET6)] --- Socket Types. -data SocketType = NotASocket -- Not a socket, used in certain operations - | Stream -- TCP - | Datagram -- UDP - | RawSocket -- Raw sockets. A guy can dream. +||| Socket Types. +data SocketType = + ||| Not a socket, used in certain operations + NotASocket | + ||| TCP + Stream | + ||| UDP + Datagram | + ||| Raw sockets + RawSocket instance Show SocketType where show NotASocket = "Not a socket" @@ -60,15 +70,17 @@ data BufPtr = BPtr Ptr data SockaddrPtr = SAPtr Ptr --- Protocol Number. Generally good enough to just set it to 0. +||| Protocol Number. +||| +||| Generally good enough to just set it to 0. ProtocolNumber : Type ProtocolNumber = Int --- SocketError: Error thrown by a socket operation +||| SocketError: Error thrown by a socket operation SocketError : Type SocketError = Int --- SocketDescriptor: Native C Socket Descriptor +||| SocketDescriptor: Native C Socket Descriptor SocketDescriptor : Type SocketDescriptor = Int @@ -86,7 +98,7 @@ Port : Type Port = Int --- Backlog used within listen() call -- number of incoming calls +||| Backlog used within listen() call -- number of incoming calls BACKLOG : Int BACKLOG = 20 @@ -109,7 +121,7 @@ (remote_port : Port) -> UDPAddrInfo --- Frees a given pointer +||| Frees a given pointer public sock_free : BufPtr -> IO () sock_free (BPtr ptr) = mkForeign (FFun "idrnet_free" [FPtr] FUnit) ptr @@ -118,12 +130,14 @@ sockaddr_free : SockaddrPtr -> IO () sockaddr_free (SAPtr ptr) = mkForeign (FFun "idrnet_free" [FPtr] FUnit) ptr --- Allocates an amount of memory given by the ByteLength parameter. --- Used to allocate a mutable pointer to be given to the Recv functions. +||| Allocates an amount of memory given by the ByteLength parameter. +||| +||| Used to allocate a mutable pointer to be given to the Recv functions. public sock_alloc : ByteLength -> IO BufPtr sock_alloc bl = map BPtr $ mkForeign (FFun "idrnet_malloc" [FInt] FPtr) bl +||| The metadata about a socket record Socket : Type where MkSocket : (descriptor : SocketDescriptor) -> (family : SocketFamily) -> @@ -131,20 +145,21 @@ (protocolNumber : ProtocolNumber) -> Socket +||| Get the C error number getErrno : IO Int getErrno = mkForeign (FFun "idrnet_errno" [] FInt) --- Creates a UNIX socket with the given family, socket type and protocol number. --- Returns either a socket or an error. +||| Creates a UNIX socket with the given family, socket type and protocol +||| number. Returns either a socket or an error. socket : SocketFamily -> SocketType -> ProtocolNumber -> IO (Either SocketError Socket) socket sf st pn = do socket_res <- mkForeign (FFun "socket" [FInt, FInt, FInt] FInt) (toCode sf) (toCode st) pn if socket_res == -1 then -- error map Left getErrno - else + else return $ Right (MkSocket socket_res sf st pn) - +||| Close a socket close : Socket -> IO () close sock = mkForeign (FFun "close" [FInt] FUnit) (descriptor sock) @@ -153,18 +168,18 @@ saString (Just sa) = show sa saString Nothing = "" --- Binds a socket to the given socket address and port. --- Returns 0 on success, an error code otherwise. +||| Binds a socket to the given socket address and port. +||| Returns 0 on success, an error code otherwise. bind : Socket -> (Maybe SocketAddress) -> Port -> IO Int bind sock addr port = do - bind_res <- (mkForeign (FFun "idrnet_bind" [FInt, FInt, FInt, FString, FInt] FInt) + bind_res <- (mkForeign (FFun "idrnet_bind" [FInt, FInt, FInt, FString, FInt] FInt) (descriptor sock) (toCode $ family sock) (toCode $ socketType sock) (saString addr) port) if bind_res == (-1) then -- error getErrno else return 0 -- Success --- Connects to a given address and port. --- Returns 0 on success, and an error number on error. +||| Connects to a given address and port. +||| Returns 0 on success, and an error number on error. connect : Socket -> SocketAddress -> Port -> IO Int connect sock addr port = do conn_res <- (mkForeign (FFun "idrnet_connect" [FInt, FInt, FInt, FString, FInt] FInt) @@ -173,7 +188,7 @@ getErrno else return 0 --- Listens on a bound socket. +||| Listens on a bound socket. listen : Socket -> IO Int listen sock = do listen_res <- mkForeign (FFun "listen" [FInt, FInt] FInt) (descriptor sock) BACKLOG @@ -181,7 +196,7 @@ getErrno else return 0 --- Parses a textual representation of an IPv4 address into a SocketAddress +||| Parses a textual representation of an IPv4 address into a SocketAddress parseIPv4 : String -> SocketAddress parseIPv4 str = case splitted of (i1 :: i2 :: i3 :: i4 :: _) => IPv4Addr i1 i2 i3 i4 @@ -194,7 +209,7 @@ splitted = map toInt (Prelude.Strings.split (\c => c == '.') str) --- Retrieves a socket address from a sockaddr pointer +||| Retrieves a socket address from a sockaddr pointer getSockAddr : SockaddrPtr -> IO SocketAddress getSockAddr (SAPtr ptr) = do addr_family_int <- mkForeign (FFun "idrnet_sockaddr_family" [FPtr] FInt) ptr @@ -256,13 +271,13 @@ return $ Right (payload, recv_res) --- Sends the data in a given memory location +||| Sends the data in a given memory location sendBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength) sendBuf sock (BPtr ptr) len = do send_res <- mkForeign (FFun "idrnet_send_buf" [FInt, FPtr, FInt] FInt) (descriptor sock) ptr len if send_res == (-1) then map Left getErrno - else + else return $ Right send_res recvBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength) @@ -313,7 +328,7 @@ recv_ptr <- mkForeign (FFun "idrnet_recvfrom" [FInt, FInt] FPtr) (descriptor sock) bl let recv_ptr' = RFPtr recv_ptr - if !(nullPtr recv_ptr) then -- ! notation = monadic bind shortcut, not "not" + if !(nullPtr recv_ptr) then map Left getErrno else do result <- mkForeign (FFun "idrnet_get_recvfrom_res" [FPtr] FInt) recv_ptr @@ -332,7 +347,7 @@ recvFromBuf sock (BPtr ptr) bl = do recv_ptr <- mkForeign (FFun "idrnet_recvfrom_buf" [FInt, FPtr, FInt] FPtr) (descriptor sock) ptr bl let recv_ptr' = RFPtr recv_ptr - if !(nullPtr recv_ptr) then -- ! notation = monadic bind shortcut, not "not" + if !(nullPtr recv_ptr) then map Left getErrno else do result <- mkForeign (FFun "idrnet_get_recvfrom_res" [FPtr] FInt) recv_ptr @@ -345,5 +360,4 @@ freeRecvfromStruct recv_ptr' return $ Right (MkUDPAddrInfo addr port, result + 1) - diff --git a/libs/base/Syntax/PreorderReasoning.idr b/libs/base/Syntax/PreorderReasoning.idr --- a/libs/base/Syntax/PreorderReasoning.idr +++ b/libs/base/Syntax/PreorderReasoning.idr @@ -1,6 +1,6 @@ module Syntax.PreorderReasoning --- QED is first to get the precedence to work out. It's just refl with an explicit argument. +-- QED is first to get the precedence to work out. It's just Refl with an explicit argument. syntax [expr] "QED" = qed expr -- foo ={ prf }= bar ={ prf' }= fnord QED -- is a proof that foo is related to fnord, with the intermediate step being bar, justified by prf and prf' @@ -9,7 +9,7 @@ namespace Equal using (a : Type, x : a, y : a, z : a) qed : (x : a) -> x = x - qed x = the (x = x) refl + qed x = the (x = x) Refl step : (x : a) -> x = y -> (y = z) -> x = z - step x refl refl = refl + step x Refl Refl = Refl diff --git a/libs/base/System/Concurrency/Process.idr b/libs/base/System/Concurrency/Process.idr --- a/libs/base/System/Concurrency/Process.idr +++ b/libs/base/System/Concurrency/Process.idr @@ -12,38 +12,38 @@ ||| Type safe message passing programs. Parameterised over the type of ||| message which can be send, and the return type. data Process : (msgType : Type) -> Type -> Type where - lift : IO a -> Process msg a + Lift : IO a -> Process msg a instance Functor (Process msg) where - map f (lift a) = lift (map f a) + map f (Lift a) = Lift (map f a) instance Applicative (Process msg) where - pure = lift . return - (lift f) <$> (lift a) = lift (f <$> a) + pure = Lift . return + (Lift f) <$> (Lift a) = Lift (f <$> a) instance Monad (Process msg) where - (lift io) >>= k = lift (do x <- io + (Lift io) >>= k = Lift (do x <- io case k x of - lift v => v) + Lift v => v) run : Process msg x -> IO x -run (lift prog) = prog +run (Lift prog) = prog ||| Get current process ID myID : Process msg (ProcID msg) -myID = lift (return (MkPID prim__vm)) +myID = Lift (return (MkPID prim__vm)) ||| Send a message to another process send : ProcID msg -> msg -> Process msg () -send (MkPID p) m = lift (sendToThread p (prim__vm, m)) +send (MkPID p) m = Lift (sendToThread p (prim__vm, m)) ||| Return whether a message is waiting in the queue msgWaiting : Process msg Bool -msgWaiting = lift checkMsgs +msgWaiting = Lift checkMsgs ||| Receive a message - blocks if there is no message waiting recv : Process msg msg -recv {msg} = do (senderid, m) <- lift get +recv {msg} = do (senderid, m) <- Lift get return m where get : IO (Ptr, msg) get = getMsg @@ -51,11 +51,11 @@ ||| receive a message, and return with the sender's process ID. recvWithSender : Process msg (ProcID msg, msg) recvWithSender {msg} - = do (senderid, m) <- lift get + = do (senderid, m) <- Lift get return (MkPID senderid, m) where get : IO (Ptr, msg) get = getMsg create : Process msg () -> Process msg (ProcID msg) -create (lift p) = do ptr <- lift (fork p) +create (Lift p) = do ptr <- Lift (fork p) return (MkPID ptr) diff --git a/libs/base/base.ipkg b/libs/base/base.ipkg --- a/libs/base/base.ipkg +++ b/libs/base/base.ipkg @@ -24,7 +24,7 @@ Data.Vect, Data.HVect, Data.Vect.Quantifiers, Data.Floats, Data.Complex, Data.Heap, Data.Fun, Data.Rel, Data.Buffer, Data.Erased, - Data.List, + Data.List, Data.Hash, Control.Isomorphism, Control.Isomorphism.Primitives, Control.Monad.Identity, diff --git a/libs/effects/Effect/Memory.idr b/libs/effects/Effect/Memory.idr --- a/libs/effects/Effect/Memory.idr +++ b/libs/effects/Effect/Memory.idr @@ -16,23 +16,23 @@ Free : RawMemory () (MemoryChunk n i) (\v => ()) Initialize : Bits8 -> (size : Nat) -> - so (i + size <= n) -> + So (i + size <= n) -> RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (i + size)) Peek : (offset : Nat) -> (size : Nat) -> - so (offset + size <= i) -> + So (offset + size <= i) -> RawMemory (Vect size Bits8) (MemoryChunk n i) (\v => MemoryChunk n i) Poke : (offset : Nat) -> (Vect size Bits8) -> - so (offset <= i && offset + size <= n) -> + So (offset <= i && offset + size <= n) -> RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size))) Move : (src : MemoryChunk src_size src_init) -> (dst_offset : Nat) -> (src_offset : Nat) -> (size : Nat) -> - so (dst_offset <= dst_init && dst_offset + size <= dst_size) -> - so (src_offset + size <= src_init) -> + So (dst_offset <= dst_init && dst_offset + size <= dst_size) -> + So (src_offset + size <= src_init) -> RawMemory () (MemoryChunk dst_size dst_init) (\v => MemoryChunk dst_size (max dst_init (dst_offset + size))) GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i) @@ -108,7 +108,7 @@ {n : Nat} -> Bits8 -> (size : Nat) -> - so (i + size <= n) -> + So (i + size <= n) -> Eff () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY (MemoryChunk n (i + size))]) initialize c size prf = call $ Initialize c size prf @@ -119,7 +119,7 @@ peek : {i : Nat} -> (offset : Nat) -> (size : Nat) -> - so (offset + size <= i) -> + So (offset + size <= i) -> { [RAW_MEMORY (MemoryChunk n i)] } Eff (Vect size Bits8) peek offset size prf = call $ Peek offset size prf @@ -127,7 +127,7 @@ {i : Nat} -> (offset : Nat) -> Vect size Bits8 -> - so (offset <= i && offset + size <= n) -> + So (offset <= i && offset + size <= n) -> Eff () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))]) poke offset content prf = call $ Poke offset content prf @@ -144,8 +144,8 @@ (dst_offset : Nat) -> (src_offset : Nat) -> (size : Nat) -> - so (dst_offset <= dst_init && dst_offset + size <= dst_size) -> - so (src_offset + size <= src_init) -> + So (dst_offset <= dst_init && dst_offset + size <= dst_size) -> + So (src_offset + size <= src_init) -> Eff () [RAW_MEMORY (MemoryChunk dst_size dst_init)] (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))]) move' src_ptr dst_offset src_offset size dst_bounds src_bounds @@ -160,8 +160,8 @@ (dst_offset : Nat) -> (src_offset : Nat) -> (size : Nat) -> - so (dst_offset <= dst_init && dst_offset + size <= dst_size) -> - so (src_offset + size <= src_init) -> + So (dst_offset <= dst_init && dst_offset + size <= dst_size) -> + So (src_offset + size <= src_init) -> Eff () [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init) , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] diff --git a/libs/effects/Effects.idr b/libs/effects/Effects.idr --- a/libs/effects/Effects.idr +++ b/libs/effects/Effects.idr @@ -136,9 +136,7 @@ data Eff : (x : Type) -> (es : List EFFECT) -> (ce : x -> List EFFECT) -> Type where - value : a -> Eff a xs (\v => xs) - with_val : (val : a) -> Eff () xs (\v => xs' val) -> - Eff a xs xs' + value : (val : a) -> Eff a (xs val) xs ebind : Eff a xs xs' -> ((val : a) -> Eff b (xs' val) xs'') -> Eff b xs xs'' callP : (prf : EffElem e a xs) -> @@ -181,7 +179,8 @@ pure : a -> Eff a xs (\v => xs) pure = value -syntax pureM [val] = with_val val (pure ()) +pureM : (val : a) -> Eff a (xs val) xs +pureM = value (<$>) : Eff (a -> b) xs (\v => xs) -> Eff a xs (\v => xs) -> Eff b xs (\v => xs) @@ -206,7 +205,6 @@ eff : Env m xs -> Eff a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b eff env (value x) k = k x env -eff env (with_val x prog) k = eff env prog (\p', env' => k x env') eff env (prog `ebind` c) k = eff env prog (\p', env' => eff env' (c p') k) eff env (callP prf effP) k = execEff env prf effP k diff --git a/libs/prelude/Builtins.idr b/libs/prelude/Builtins.idr --- a/libs/prelude/Builtins.idr +++ b/libs/prelude/Builtins.idr @@ -3,14 +3,40 @@ %access public %default total -||| Dependent pairs, in their internal representation -||| @ a the type of the witness -||| @ P the type of the proof +||| The canonical single-element type, also known as the trivially +||| true proposition. +%elim data Unit = + ||| The trivial constructor for `()`. + MkUnit + +||| The non-dependent pair type, also known as conjunction. +||| @A the type of the left elements in the pair +||| @B the type of the left elements in the pair +data Pair : (A : Type) -> (B : Type) -> Type where + ||| A pair of elements + ||| @a the left element of the pair + ||| @b the right element of the pair + MkPair : {A, B : Type} -> (a : A) -> (b : B) -> Pair A B + +||| Dependent pairs +||| +||| Dependent pairs represent existential quantification - they consist of a +||| witness for the existential claim and a proof that the property holds for +||| it. Another way to see dependent pairs is as just data - for instance, the +||| length of a vector paired with that vector. +||| +||| @ a the type of the witness @ P the type of the proof data Sigma : (a : Type) -> (P : a -> Type) -> Type where - Sg_intro : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P + MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P -||| The eliminator for the empty type. -FalseElim : _|_ -> a +||| The empty type, also known as the trivially false proposition. +||| +||| Use `void` or `absurd` to prove anything if you have a variable of type `Void` in scope. +%elim data Void : Type where + +||| The eliminator for the `Void` type. +void : Void -> a +void {a} v = elim_for Void (\_ => a) v ||| For 'symbol syntax. 'foo becomes Symbol_ "foo" data Symbol_ : String -> Type where @@ -27,20 +53,19 @@ (~=~) : (x : a) -> (y : b) -> Type (~=~) x y = (=) _ _ x y --- ------------------------------------------------------ [ For rewrite tactic ] ||| Perform substitution in a term according to some equality. ||| ||| This is used by the `rewrite` tactic and term. replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y -replace refl prf = prf +replace Refl prf = prf ||| Symmetry of propositional equality sym : {l:a} -> {r:a} -> l = r -> r = l -sym refl = refl +sym Refl = Refl ||| Transitivity of propositional equality trans : {a:x} -> {b:y} -> {c:z} -> a = b -> b = c -> a = c -trans refl refl = refl +trans Refl Refl = Refl ||| There are two types of laziness: that arising from lazy functions, and that ||| arising from codata. They differ in their totality condition. @@ -79,7 +104,7 @@ ||| A read-only version of a unique value data Borrowed : UniqueType -> NullType where Read : {a : UniqueType} -> a -> Borrowed a - + ||| Make a read-only version of a unique value, which can be passed to another ||| function without the unique value being consumed. implicit @@ -88,13 +113,7 @@ par : Lazy a -> a -- Doesn't actually do anything yet. Maybe a 'Par a' type -- is better in any case? -par (Delay x) = x - -malloc : Int -> a -> a -malloc size x = x -- compiled specially - -trace_malloc : a -> a -trace_malloc x = x -- compiled specially +par (Delay x) = x ||| Assert to the totality checker than y is always structurally smaller than ||| x (which is typically a pattern argument) @@ -119,4 +138,3 @@ public %assert_total really_believe_me : a -> b really_believe_me x = prim__believe_me _ _ x - diff --git a/libs/prelude/Decidable/Equality.idr b/libs/prelude/Decidable/Equality.idr --- a/libs/prelude/Decidable/Equality.idr +++ b/libs/prelude/Decidable/Equality.idr @@ -13,7 +13,7 @@ -------------------------------------------------------------------------------- ||| The negation of equality is symmetric (follows from symmetry of equality) -total negEqSym : {a : t} -> {b : t} -> (a = b -> _|_) -> (b = a -> _|_) +total negEqSym : {a : t} -> {b : t} -> (a = b -> Void) -> (b = a -> Void) negEqSym p h = p (sym h) @@ -31,17 +31,17 @@ -------------------------------------------------------------------------------- instance DecEq () where - decEq () () = Yes refl + decEq () () = Yes Refl -------------------------------------------------------------------------------- -- Booleans -------------------------------------------------------------------------------- -total trueNotFalse : True = False -> _|_ -trueNotFalse refl impossible +total trueNotFalse : True = False -> Void +trueNotFalse Refl impossible instance DecEq Bool where - decEq True True = Yes refl - decEq False False = Yes refl + decEq True True = Yes Refl + decEq False False = Yes Refl decEq True False = No trueNotFalse decEq False True = No (negEqSym trueNotFalse) @@ -49,11 +49,11 @@ -- Nat -------------------------------------------------------------------------------- -total OnotS : Z = S n -> _|_ -OnotS refl impossible +total OnotS : Z = S n -> Void +OnotS Refl impossible instance DecEq Nat where - decEq Z Z = Yes refl + decEq Z Z = Yes Refl decEq Z (S _) = No OnotS decEq (S _) Z = No (negEqSym OnotS) decEq (S n) (S m) with (decEq n m) @@ -64,11 +64,11 @@ -- Maybe -------------------------------------------------------------------------------- -total nothingNotJust : {x : t} -> (Nothing {a = t} = Just x) -> _|_ -nothingNotJust refl impossible +total nothingNotJust : {x : t} -> (Nothing {a = t} = Just x) -> Void +nothingNotJust Refl impossible instance (DecEq t) => DecEq (Maybe t) where - decEq Nothing Nothing = Yes refl + decEq Nothing Nothing = Yes Refl decEq (Just x') (Just y') with (decEq x' y') | Yes p = Yes $ cong p | No p = No $ \h : Just x' = Just y' => p $ justInjective h @@ -79,8 +79,8 @@ -- Either -------------------------------------------------------------------------------- -total leftNotRight : {x : a} -> {y : b} -> Left {b = b} x = Right {a = a} y -> _|_ -leftNotRight refl impossible +total leftNotRight : {x : a} -> {y : b} -> Left {b = b} x = Right {a = a} y -> Void +leftNotRight Refl impossible instance (DecEq a, DecEq b) => DecEq (Either a b) where decEq (Left x') (Left y') with (decEq x' y') @@ -96,40 +96,40 @@ -- Fin -------------------------------------------------------------------------------- -total fZNotfS : {f : Fin n} -> fZ {k = n} = fS f -> _|_ -fZNotfS refl impossible +total FZNotFS : {f : Fin n} -> FZ {k = n} = FS f -> Void +FZNotFS Refl impossible instance DecEq (Fin n) where - decEq fZ fZ = Yes refl - decEq fZ (fS f) = No fZNotfS - decEq (fS f) fZ = No $ negEqSym fZNotfS - decEq (fS f) (fS f') with (decEq f f') + decEq FZ FZ = Yes Refl + decEq FZ (FS f) = No FZNotFS + decEq (FS f) FZ = No $ negEqSym FZNotFS + decEq (FS f) (FS f') with (decEq f f') | Yes p = Yes $ cong p - | No p = No $ \h => p $ fSinjective {f = f} {f' = f'} h + | No p = No $ \h => p $ FSinjective {f = f} {f' = f'} h -------------------------------------------------------------------------------- -- Tuple -------------------------------------------------------------------------------- -lemma_both_neq : {x : a, y : b, x' : c, y' : d} -> (x = x' -> _|_) -> (y = y' -> _|_) -> ((x, y) = (x', y') -> _|_) -lemma_both_neq p_x_not_x' p_y_not_y' refl = p_x_not_x' refl +lemma_both_neq : {x : a, y : b, x' : c, y' : d} -> (x = x' -> Void) -> (y = y' -> Void) -> ((x, y) = (x', y') -> Void) +lemma_both_neq p_x_not_x' p_y_not_y' Refl = p_x_not_x' Refl -lemma_snd_neq : {x : a, y : b, y' : d} -> (x = x) -> (y = y' -> _|_) -> ((x, y) = (x, y') -> _|_) -lemma_snd_neq refl p refl = p refl +lemma_snd_neq : {x : a, y : b, y' : d} -> (x = x) -> (y = y' -> Void) -> ((x, y) = (x, y') -> Void) +lemma_snd_neq Refl p Refl = p Refl lemma_fst_neq_snd_eq : {x : a, x' : b, y : c, y' : d} -> - (x = x' -> _|_) -> + (x = x' -> Void) -> (y = y') -> - ((x, y) = (x', y) -> _|_) -lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl + ((x, y) = (x', y) -> Void) +lemma_fst_neq_snd_eq p_x_not_x' Refl Refl = p_x_not_x' Refl instance (DecEq a, DecEq b) => DecEq (a, b) where decEq (a, b) (a', b') with (decEq a a') - decEq (a, b) (a, b') | (Yes refl) with (decEq b b') - decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl - decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq) + decEq (a, b) (a, b') | (Yes Refl) with (decEq b b') + decEq (a, b) (a, b) | (Yes Refl) | (Yes Refl) = Yes Refl + decEq (a, b) (a, b') | (Yes Refl) | (No p) = No (\eq => lemma_snd_neq Refl p eq) decEq (a, b) (a', b') | (No p) with (decEq b b') - decEq (a, b) (a', b) | (No p) | (Yes refl) = No (\eq => lemma_fst_neq_snd_eq p refl eq) + decEq (a, b) (a', b) | (No p) | (Yes Refl) = No (\eq => lemma_fst_neq_snd_eq p Refl eq) decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq) @@ -137,28 +137,28 @@ -- List -------------------------------------------------------------------------------- -lemma_val_not_nil : {x : t, xs : List t} -> ((x :: xs) = Prelude.List.Nil {a = t} -> _|_) -lemma_val_not_nil refl impossible +lemma_val_not_nil : {x : t, xs : List t} -> ((x :: xs) = Prelude.List.Nil {a = t} -> Void) +lemma_val_not_nil Refl impossible -lemma_x_eq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y) -> (xs = ys -> _|_) -> ((x :: xs) = (y :: ys) -> _|_) -lemma_x_eq_xs_neq refl p refl = p refl +lemma_x_eq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y) -> (xs = ys -> Void) -> ((x :: xs) = (y :: ys) -> Void) +lemma_x_eq_xs_neq Refl p Refl = p Refl -lemma_x_neq_xs_eq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> _|_) -> (xs = ys) -> ((x :: xs) = (y :: ys) -> _|_) -lemma_x_neq_xs_eq p refl refl = p refl +lemma_x_neq_xs_eq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> Void) -> (xs = ys) -> ((x :: xs) = (y :: ys) -> Void) +lemma_x_neq_xs_eq p Refl Refl = p Refl -lemma_x_neq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> _|_) -> (xs = ys -> _|_) -> ((x :: xs) = (y :: ys) -> _|_) -lemma_x_neq_xs_neq p p' refl = p refl +lemma_x_neq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> Void) -> (xs = ys -> Void) -> ((x :: xs) = (y :: ys) -> Void) +lemma_x_neq_xs_neq p p' Refl = p Refl instance DecEq a => DecEq (List a) where - decEq [] [] = Yes refl + decEq [] [] = Yes Refl decEq (x :: xs) [] = No lemma_val_not_nil decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil) decEq (x :: xs) (y :: ys) with (decEq x y) - decEq (x :: xs) (x :: ys) | Yes refl with (decEq xs ys) - decEq (x :: xs) (x :: xs) | (Yes refl) | (Yes refl) = Yes refl - decEq (x :: xs) (x :: ys) | (Yes refl) | (No p) = No (\eq => lemma_x_eq_xs_neq refl p eq) + decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys) + decEq (x :: xs) (x :: xs) | (Yes Refl) | (Yes Refl) = Yes Refl + decEq (x :: xs) (x :: ys) | (Yes Refl) | (No p) = No (\eq => lemma_x_eq_xs_neq Refl p eq) decEq (x :: xs) (y :: ys) | No p with (decEq xs ys) - decEq (x :: xs) (y :: xs) | (No p) | (Yes refl) = No (\eq => lemma_x_neq_xs_eq p refl eq) + decEq (x :: xs) (y :: xs) | (No p) | (Yes Refl) = No (\eq => lemma_x_neq_xs_eq p Refl eq) decEq (x :: xs) (y :: ys) | (No p) | (No p') = No (\eq => lemma_x_neq_xs_neq p p' eq) @@ -168,26 +168,26 @@ 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 +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 +vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl instance DecEq a => DecEq (Vect n a) where - decEq [] [] = Yes refl + decEq [] [] = Yes Refl decEq (x :: xs) (y :: ys) with (decEq x y) - decEq (x :: xs) (x :: ys) | Yes refl with (decEq xs ys) - decEq (x :: xs) (x :: xs) | Yes refl | Yes refl = Yes refl - decEq (x :: xs) (x :: ys) | Yes refl | No neq = No (neq . vectInjective2) + decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys) + decEq (x :: xs) (x :: xs) | Yes Refl | Yes Refl = Yes Refl + decEq (x :: xs) (x :: ys) | Yes Refl | No neq = No (neq . vectInjective2) decEq (x :: xs) (y :: ys) | No neq = No (neq . vectInjective1) {- The following definition is elaborated in a wrong case-tree. Examination pending. instance DecEq a => DecEq (Vect n a) where - decEq [] [] = Yes refl + 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) (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)) -} @@ -202,8 +202,8 @@ instance DecEq Int where decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq where primitiveEq : x = y - primitiveEq = believe_me (refl {x}) - postulate primitiveNotEq : x = y -> _|_ + primitiveEq = believe_me (Refl {x}) + postulate primitiveNotEq : x = y -> Void -------------------------------------------------------------------------------- -- Char @@ -212,8 +212,8 @@ instance DecEq Char where decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq where primitiveEq : x = y - primitiveEq = believe_me (refl {x}) - postulate primitiveNotEq : x = y -> _|_ + primitiveEq = believe_me (Refl {x}) + postulate primitiveNotEq : x = y -> Void -------------------------------------------------------------------------------- -- Integer @@ -222,8 +222,8 @@ instance DecEq Integer where decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq where primitiveEq : x = y - primitiveEq = believe_me (refl {x}) - postulate primitiveNotEq : x = y -> _|_ + primitiveEq = believe_me (Refl {x}) + postulate primitiveNotEq : x = y -> Void -------------------------------------------------------------------------------- -- Float @@ -232,8 +232,8 @@ instance DecEq Float where decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq where primitiveEq : x = y - primitiveEq = believe_me (refl {x}) - postulate primitiveNotEq : x = y -> _|_ + primitiveEq = believe_me (Refl {x}) + postulate primitiveNotEq : x = y -> Void -------------------------------------------------------------------------------- -- String @@ -242,7 +242,7 @@ instance DecEq String where decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq where primitiveEq : x = y - primitiveEq = believe_me (refl {x}) - postulate primitiveNotEq : x = y -> _|_ + primitiveEq = believe_me (Refl {x}) + postulate primitiveNotEq : x = y -> Void diff --git a/libs/prelude/Prelude.idr b/libs/prelude/Prelude.idr --- a/libs/prelude/Prelude.idr +++ b/libs/prelude/Prelude.idr @@ -420,9 +420,9 @@ go (x :: xs) = n + (cast x * inc) :: go xs instance Enum (Fin (S n)) where - pred fZ = fZ - pred (fS n) = weaken n - succ n = case strengthen (fS n) of + pred FZ = FZ + pred (FS n) = weaken n + succ n = case strengthen (FS n) of Left _ => last Right k => k toNat n = cast n @@ -494,6 +494,7 @@ ---- some basic file handling +||| A file handle abstract data File = FHandle Ptr @@ -592,6 +593,7 @@ do_feof : Ptr -> IO Int do_feof h = mkForeign (FFun "fileEOF" [FPtr] FInt) h +||| Check if a file handle has reached the end feof : File -> IO Bool feof (FHandle h) = do eof <- do_feof h return (not (eof == 0)) @@ -608,6 +610,7 @@ fpoll (FHandle h) = do p <- mkForeign (FFun "fpoll" [FPtr] FInt) h return (p > 0) +||| Check if a foreign pointer is null partial nullPtr : Ptr -> IO Bool nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p @@ -630,6 +633,10 @@ validFile (FHandle h) = do x <- nullPtr h return (not x) +||| Loop while some test is true +||| +||| @ test the condition of the loop +||| @ body the loop body partial -- obviously while : (test : IO Bool) -> (body : IO ()) -> IO () while t b = do v <- t @@ -637,6 +644,7 @@ while t b else return () +||| Read the contents of a file into a string partial -- no error checking! readFile : String -> IO String readFile fn = do h <- openFile fn Read diff --git a/libs/prelude/Prelude/Algebra.idr b/libs/prelude/Prelude/Algebra.idr --- a/libs/prelude/Prelude/Algebra.idr +++ b/libs/prelude/Prelude/Algebra.idr @@ -123,7 +123,7 @@ ||| + Inverse for `<+>`: ||| forall a, a <+> inverse a == neutral ||| forall a, inverse a <+> a == neutral -||| + Associativity of `<*>a: +||| + Associativity of `<*>`: ||| forall a b c, a <*> (b <*> c) == (a <*> b) <*> c ||| + Neutral for `<*>`: ||| forall a, a <*> unity == a @@ -264,9 +264,61 @@ class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { } +-- Fields. +||| Sets equipped with two binary operations, both associative and commutative +||| supplied with a neutral element, with +||| distributivity laws relating the two operations. Must satisfy the following +||| laws: +||| +||| + Associativity of `<+>`: +||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c +||| + Commutativity of `<+>`: +||| forall a b, a <+> b == b <+> a +||| + Neutral for `<+>`: +||| forall a, a <+> neutral == a +||| forall a, neutral <+> a == a +||| + Inverse for `<+>`: +||| forall a, a <+> inverse a == neutral +||| forall a, inverse a <+> a == neutral +||| + Associativity of `<*>`: +||| forall a b c, a <*> (b <*> c) == (a <*> b) <*> c +||| + Unity for `<*>`: +||| forall a, a <*> unity == a +||| forall a, unity <*> a == a +||| + InverseM of `<*>`: +||| forall a, a <*> inverseM a == unity +||| forall a, inverseM a <*> a == unity +||| + Distributivity of `<*>` and `<->`: +||| forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c) +||| forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c) +class RingWithUnity a => Field a where + inverseM : a -> a +class (VerifiedRing a, Field a) => VerifiedField a where + total fieldInverseIsInverseL : (l : a) -> l <*> inverseM l = unity + total fieldInverseIsInverseR : (r : a) -> inverseM r <*> r = unity + +-- vector spaces. +||| A Vector Space over a Field can be considered as an additive Abeliean Group +||| of Vectors adjoined to the Field structure by distributivity laws relating +||| the two operations. Such that we satisfy the following laws: +||| +||| + Unity for `<*>`: +||| forall a, a <*> unity == a +||| forall a, unity <*> a == a +||| + Distributivity of `<*>` and `<+>`: +||| forall a x y, a <*> (x <+> y) == (a <*> x) <+> (a <*> y) +||| forall a b x, (a <+> b) <*> x == (a <*> x) <+> (b <*> x) +class (Field a, AbelianGroup a) => VectorSpace a a where {} + +class (VerifiedField a, VerifiedAbelianGroup a, VectorSpace a a) => VerifiedVectorSpace a a where + total vectorspaceScalarUnityIsUnityL : (l : a) -> l <*> unity = l + total vectorspaceScalarUnityIsUnityR : (r : a) -> unity <*> r = r + total vectorspaceScalarIsDistributiveWRTVectorAddition : (s : a) -> (x, y : a) -> s <*> (x <+> y) = (s <*> x) <+> (s <*> y) + total vectorspaceScalarIsDistributiveWRTFieldAddition : (s, t : a) -> (x : a) -> (s <+> t) <*> x = (s <*> x) <+> (t <*> x) + + -- XXX todo: --- Fields and vector spaces. -- Structures where "abs" make sense. -- Euclidean domains, etc. -- Where to put fromInteger and fromRational? diff --git a/libs/prelude/Prelude/Basics.idr b/libs/prelude/Prelude/Basics.idr --- a/libs/prelude/Prelude/Basics.idr +++ b/libs/prelude/Prelude/Basics.idr @@ -1,7 +1,9 @@ module Prelude.Basics +import Builtins + Not : Type -> Type -Not a = a -> _|_ +Not a = a -> Void ||| Identity function. id : a -> a @@ -42,7 +44,7 @@ ||| Equality is a congruence. cong : {f : t -> u} -> (a = b) -> f a = f b -cong refl = refl +cong Refl = Refl ||| Decidability. A decidable property either holds or is a contradiction. data Dec : Type -> Type where @@ -53,5 +55,5 @@ ||| The case where the property holding would be a contradiction ||| @ contra a demonstration that A would be a contradiction - No : {A : Type} -> (contra : A -> _|_) -> Dec A + No : {A : Type} -> (contra : A -> Void) -> Dec A diff --git a/libs/prelude/Prelude/Bool.idr b/libs/prelude/Prelude/Bool.idr --- a/libs/prelude/Prelude/Bool.idr +++ b/libs/prelude/Prelude/Bool.idr @@ -21,13 +21,14 @@ ||| if you need to perform a Boolean test and convince the type checker of this ||| fact. ||| -||| If you find yourself using `so` for something other than primitive types, +||| If you find yourself using `So` for something other than primitive types, ||| it may be appropriate to define a type of evidence for the property that you ||| care about instead. -data so : Bool -> Type where oh : so True +data So : Bool -> Type where + Oh : So True -instance Uninhabited (so False) where - uninhabited oh impossible +instance Uninhabited (So False) where + uninhabited Oh impossible -- Syntactic sugar for boolean elimination. syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e) diff --git a/libs/prelude/Prelude/Classes.idr b/libs/prelude/Prelude/Classes.idr --- a/libs/prelude/Prelude/Classes.idr +++ b/libs/prelude/Prelude/Classes.idr @@ -137,6 +137,21 @@ then compare xl yl else compare xr yr +-- --------------------------------------------------------- [ Negatable Class ] +||| The `Neg` class defines unary negation (-). +class Neg a where + ||| The underlying implementation of unary minus. `-5` desugars to `negate (fromInteger 5)`. + negate : a -> a + +instance Neg Integer where + negate x = prim__subBigInt 0 x + +instance Neg Int where + negate x = prim__subInt 0 x + +instance Neg Float where + negate x = prim__negFloat x + -- --------------------------------------------------------- [ Numerical Class ] ||| The Num class defines basic numerical arithmetic. class Num a where diff --git a/libs/prelude/Prelude/Either.idr b/libs/prelude/Prelude/Either.idr --- a/libs/prelude/Prelude/Either.idr +++ b/libs/prelude/Prelude/Either.idr @@ -30,10 +30,10 @@ -- Misc. -------------------------------------------------------------------------------- -||| Perform a case analysis on a Boolean, providing clients with a `so` proof -choose : (b : Bool) -> Either (so b) (so (not b)) -choose True = Left oh -choose False = Right oh +||| Perform a case analysis on a Boolean, providing clients with a `So` proof +choose : (b : Bool) -> Either (So b) (So (not b)) +choose True = Left Oh +choose False = Right Oh ||| Simply-typed eliminator for Either ||| @ f the action to take on Left @@ -97,9 +97,9 @@ ||| Left is injective total leftInjective : {b : Type} -> {x : a} -> {y : a} -> (Left {b = b} x = Left {b = b} y) -> (x = y) -leftInjective refl = refl +leftInjective Refl = Refl ||| Right is injective total rightInjective : {a : Type} -> {x : b} -> {y : b} -> (Right {a = a} x = Right {a = a} y) -> (x = y) -rightInjective refl = refl +rightInjective Refl = Refl diff --git a/libs/prelude/Prelude/Fin.idr b/libs/prelude/Prelude/Fin.idr --- a/libs/prelude/Prelude/Fin.idr +++ b/libs/prelude/Prelude/Fin.idr @@ -12,39 +12,39 @@ ||| exceedingly inefficient at run time. ||| @ n the upper bound data Fin : (n : Nat) -> Type where - fZ : Fin (S k) - fS : Fin k -> Fin (S k) + FZ : Fin (S k) + FS : Fin k -> Fin (S k) instance Uninhabited (Fin Z) where - uninhabited fZ impossible - uninhabited (fS f) impossible + uninhabited FZ impossible + uninhabited (FS f) impossible -fSInjective : (m : Fin k) -> (n : Fin k) -> fS m = fS n -> m = n -fSInjective left _ refl = refl +FSInjective : (m : Fin k) -> (n : Fin k) -> FS m = FS n -> m = n +FSInjective left _ Refl = Refl instance Eq (Fin n) where - (==) fZ fZ = True - (==) (fS k) (fS k') = k == k' + (==) FZ FZ = True + (==) (FS k) (FS k') = k == k' (==) _ _ = False ||| There are no elements of `Fin Z` -FinZAbsurd : Fin Z -> _|_ -FinZAbsurd fZ impossible +FinZAbsurd : Fin Z -> Void +FinZAbsurd FZ impossible FinZElim : Fin Z -> a -FinZElim x = FalseElim (FinZAbsurd x) +FinZElim x = void (FinZAbsurd x) ||| Convert a Fin to a Nat finToNat : Fin n -> Nat -finToNat fZ = Z -finToNat (fS k) = S (finToNat k) +finToNat FZ = Z +finToNat (FS k) = S (finToNat k) ||| `finToNat` is injective finToNatInjective : (fm : Fin k) -> (fn : Fin k) -> (finToNat fm) = (finToNat fn) -> fm = fn -finToNatInjective fZ fZ refl = refl -finToNatInjective (fS m) fZ refl impossible -finToNatInjective fZ (fS n) refl impossible -finToNatInjective (fS m) (fS n) prf = +finToNatInjective FZ FZ Refl = Refl +finToNatInjective (FS m) FZ Refl impossible +finToNatInjective FZ (FS n) Refl impossible +finToNatInjective (FS m) (FS n) prf = cong (finToNatInjective m n (succInjective (finToNat m) (finToNat n) prf)) instance Cast (Fin n) Nat where @@ -52,29 +52,29 @@ ||| Convert a Fin to an Integer finToInteger : Fin n -> Integer -finToInteger fZ = 0 -finToInteger (fS k) = 1 + finToInteger k +finToInteger FZ = 0 +finToInteger (FS k) = 1 + finToInteger k instance Cast (Fin n) Integer where cast x = finToInteger x ||| Weaken the bound on a Fin by 1 weaken : Fin n -> Fin (S n) -weaken fZ = fZ -weaken (fS k) = fS (weaken k) +weaken FZ = FZ +weaken (FS k) = FS (weaken k) ||| Weaken the bound on a Fin by some amount weakenN : (n : Nat) -> Fin m -> Fin (m + n) -weakenN n fZ = fZ -weakenN n (fS f) = fS (weakenN n f) +weakenN n FZ = FZ +weakenN n (FS f) = FS (weakenN n f) ||| Attempt to tighten the bound on a Fin. ||| Return `Left` if the bound could not be tightened, or `Right` if it could. strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n) -strengthen {n = S k} fZ = Right fZ -strengthen {n = S k} (fS i) with (strengthen i) - strengthen (fS k) | Left x = Left (fS x) - strengthen (fS k) | Right x = Right (fS x) +strengthen {n = S k} FZ = Right FZ +strengthen {n = S k} (FS i) with (strengthen i) + strengthen (FS k) | Left x = Left (FS x) + strengthen (FS k) | Right x = Right (FS x) strengthen f = Left f ||| Add some natural number to a Fin, extending the bound accordingly @@ -82,24 +82,24 @@ ||| @ m the number to increase the Fin by shift : (m : Nat) -> Fin n -> Fin (m + n) shift Z f = f -shift {n=n} (S m) f = fS {k = (m + n)} (shift m f) +shift {n=n} (S m) f = FS {k = (m + n)} (shift m f) ||| The largest element of some Fin type last : Fin (S n) -last {n=Z} = fZ -last {n=S _} = fS last +last {n=Z} = FZ +last {n=S _} = FS last -total fSinjective : {f : Fin n} -> {f' : Fin n} -> (fS f = fS f') -> f = f' -fSinjective refl = refl +total FSinjective : {f : Fin n} -> {f' : Fin n} -> (FS f = FS f') -> f = f' +FSinjective Refl = Refl instance Ord (Fin n) where - compare fZ fZ = EQ - compare fZ (fS _) = LT - compare (fS _) fZ = GT - compare (fS x) (fS y) = compare x y + compare FZ FZ = EQ + compare FZ (FS _) = LT + compare (FS _) FZ = GT + compare (FS x) (FS y) = compare x y instance MinBound (Fin (S n)) where - minBound = fZ + minBound = FZ instance MaxBound (Fin (S n)) where maxBound = last @@ -107,28 +107,28 @@ ||| Add two Fins, extending the bound (+) : Fin n -> Fin m -> Fin (n + m) -(+) {n=S n} {m=m} fZ f' = rewrite plusCommutative n m in weaken (weakenN n f') -(+) (fS f) f' = fS (f + f') +(+) {n=S n} {m=m} FZ f' = rewrite plusCommutative n m in weaken (weakenN n f') +(+) (FS f) f' = FS (f + f') ||| Substract two Fins, keeping the bound of the minuend (-) : Fin n -> Fin m -> Fin n -fZ - _ = fZ -f - fZ = f -(fS f) - (fS f') = weaken $ f - f' +FZ - _ = FZ +f - FZ = f +(FS f) - (FS f') = weaken $ f - f' ||| Multiply two Fins, extending the bound (*) : Fin n -> Fin m -> Fin (n * m) (*) {n=Z} f f' = FinZElim f (*) {m=Z} f f' = FinZElim f' -(*) {n=S n} {m=S m} fZ f' = fZ -(*) {n=S n} {m=S m} (fS f) f' = f' + (f * f') +(*) {n=S n} {m=S m} FZ f' = FZ +(*) {n=S n} {m=S m} (FS f) f' = f' + (f * f') -- Construct a Fin from an integer literal which must fit in the given Fin natToFin : Nat -> (n : Nat) -> Maybe (Fin n) -natToFin Z (S j) = Just fZ +natToFin Z (S j) = Just FZ natToFin (S k) (S j) with (natToFin k j) - | Just k' = Just (fS k') + | Just k' = Just (FS k') | Nothing = Nothing natToFin _ _ = Nothing diff --git a/libs/prelude/Prelude/Foldable.idr b/libs/prelude/Prelude/Foldable.idr --- a/libs/prelude/Prelude/Foldable.idr +++ b/libs/prelude/Prelude/Foldable.idr @@ -38,13 +38,13 @@ ||| predicate to all elements of a structure. `any` short-circuits ||| from left to right. any : Foldable t => (a -> Bool) -> t a -> Bool -any p = foldl (\x => \y => x || p y) False +any p = foldl (\x,y => x || p y) False ||| The disjunction of the collective results of applying a ||| predicate to all elements of a structure. `all` short-circuits ||| from left to right. all : Foldable t => (a -> Bool) -> t a -> Bool -all p = foldl (\x => \y => x && p y) True +all p = foldl (\x,y => x && p y) True ||| Add together all the elements of a structure sum : (Foldable t, Num a) => t a -> a diff --git a/libs/prelude/Prelude/List.idr b/libs/prelude/Prelude/List.idr --- a/libs/prelude/Prelude/List.idr +++ b/libs/prelude/Prelude/List.idr @@ -60,7 +60,7 @@ index : (n : Nat) -> (l : List a) -> (ok : lt n (length l) = True) -> a index Z (x::xs) p = x index (S n) (x::xs) p = index n xs ?indexTailProof -index _ [] refl impossible +index _ [] Refl impossible ||| Attempt to find a particular element of a list. ||| @@ -73,7 +73,7 @@ ||| Get the first element of a non-empty list ||| @ ok proof that the list is non-empty head : (l : List a) -> {auto ok : isCons l = True} -> a -head [] {ok=refl} impossible +head [] {ok=Refl} impossible head (x::xs) {ok=p} = x ||| Attempt to get the first element of a list. If the list is empty, return @@ -85,7 +85,7 @@ ||| Get the tail of a non-empty list. ||| @ ok proof that the list is non-empty tail : (l : List a) -> {auto ok : isCons l = True} -> List a -tail [] {ok=refl} impossible +tail [] {ok=Refl} impossible tail (x::xs) {ok=p} = xs ||| Attempt to get the tail of a list. @@ -98,9 +98,9 @@ ||| Retrieve the last element of a non-empty list. ||| @ ok proof that the list is non-empty last : (l : List a) -> {auto ok : isCons l = True} -> a -last [] {ok=refl} impossible +last [] {ok=Refl} impossible last [x] {ok=p} = x -last (x::y::ys) {ok=p} = last (y::ys) {ok=refl} +last (x::y::ys) {ok=p} = last (y::ys) {ok=Refl} ||| Attempt to retrieve the last element of a non-empty list. ||| @@ -115,9 +115,9 @@ ||| Return all but the last element of a non-empty list. ||| @ ok proof that the list is non-empty init : (l : List a) -> {auto ok : isCons l = True} -> List a -init [] {ok=refl} impossible +init [] {ok=Refl} impossible init [x] {ok=p} = [] -init (x::y::ys) {ok=p} = x :: init (y::ys) {ok=refl} +init (x::y::ys) {ok=p} = x :: init (y::ys) {ok=Refl} ||| Attempt to Return all but the last element of a list. ||| @@ -157,7 +157,7 @@ drop (S n) [] = [] drop (S n) (x::xs) = drop n xs -||| Take the longest prefix of a list such that all elements satsify some +||| Take the longest prefix of a list such that all elements satisfy some ||| Boolean predicate. ||| ||| @ p the predicate @@ -165,7 +165,7 @@ takeWhile p [] = [] takeWhile p (x::xs) = if p x then x :: takeWhile p xs else [] -||| Remove the longest prefix of a list such that all removed elements satsify some +||| Remove the longest prefix of a list such that all removed elements satisfy some ||| Boolean predicate. ||| ||| @ p the predicate @@ -251,8 +251,8 @@ ||| @ ok a proof that the lengths of the inputs are equal zipWith : (f : a -> b -> c) -> (l : List a) -> (r : List b) -> (ok : length l = length r) -> List c -zipWith f [] (y::ys) refl impossible -zipWith f (x::xs) [] refl impossible +zipWith f [] (y::ys) Refl impossible +zipWith f (x::xs) [] Refl impossible zipWith f [] [] p = [] zipWith f (x::xs) (y::ys) p = f x y :: (zipWith f xs ys ?zipWithTailProof) @@ -265,22 +265,22 @@ ||| @ ok' a proof that the lengths of the second and third inputs are equal zipWith3 : (f : a -> b -> c -> d) -> (x : List a) -> (y : List b) -> (z : List c) -> (ok : length x = length y) -> (ok' : length y = length z) -> List d -zipWith3 f _ [] (z::zs) p refl impossible -zipWith3 f _ (y::ys) [] p refl impossible -zipWith3 f [] (y::ys) _ refl q impossible -zipWith3 f (x::xs) [] _ refl q impossible +zipWith3 f _ [] (z::zs) p Refl impossible +zipWith3 f _ (y::ys) [] p Refl impossible +zipWith3 f [] (y::ys) _ Refl q impossible +zipWith3 f (x::xs) [] _ Refl q impossible zipWith3 f [] [] [] p q = [] zipWith3 f (x::xs) (y::ys) (z::zs) p q = f x y z :: (zipWith3 f xs ys zs ?zipWith3TailProof ?zipWith3TailProof') ||| Combine two lists elementwise into pairs zip : (l : List a) -> (r : List b) -> (length l = length r) -> List (a, b) -zip = zipWith (\x => \y => (x, y)) +zip = zipWith (\x,y => (x, y)) ||| Combine three lists elementwise into tuples zip3 : (x : List a) -> (y : List b) -> (z : List c) -> (length x = length y) -> (length y = length z) -> List (a, b, c) -zip3 = zipWith3 (\x => \y => \z => (x, y, z)) +zip3 = zipWith3 (\x,y,z => (x, y, z)) ||| Split a list of pairs into two lists unzip : List (a, b) -> (List a, List b) @@ -340,11 +340,16 @@ reverse' acc (x::xs) = reverse' (x::acc) xs ||| Insert some separator between the elements of a list. +||| +||| ````idris example +||| with List (intersperse ',' ['a', 'b', 'c', 'd', 'e']) +||| ```` +||| intersperse : a -> List a -> List a intersperse sep [] = [] intersperse sep (x::xs) = x :: intersperse' sep xs where --- intersperse' : a -> List a -> List a + intersperse' : a -> List a -> List a intersperse' sep [] = [] intersperse' sep (y::ys) = sep :: y :: intersperse' sep ys @@ -353,13 +358,15 @@ ||| Transposes rows and columns of a list of lists. ||| -||| > transpose [[1, 2], [3, 4]] = [[1, 3], [2, 4]] +||| ```idris example +||| with List transpose [[1, 2], [3, 4]] +||| ``` ||| ||| This also works for non square scenarios, thus ||| involution does not always hold: ||| -||| > transpose [[], [1, 2]] = [[1], [2]] -||| > transpose (transpose [[], [1, 2]]) = [[1, 2]] +||| transpose [[], [1, 2]] = [[1], [2]] +||| transpose (transpose [[], [1, 2]]) = [[1, 2]] ||| ||| TODO: Solution which satisfies the totality checker? %assert_total @@ -468,6 +475,12 @@ -- Filters -------------------------------------------------------------------------------- +||| filter, applied to a predicate and a list, returns the list of those elements that satisfy the predicate; e.g., +||| +||| ````idris example +||| filter (< 3) [Z, S Z, S (S Z), S (S (S Z)), S (S (S (S Z)))] +||| ```` +||| filter : (a -> Bool) -> List a -> List a filter p [] = [] filter p (x::xs) = @@ -476,6 +489,7 @@ else filter p xs +||| The nubBy function behaves just like nub, except it uses a user-supplied equality predicate instead of the overloaded == function. nubBy : (a -> a -> Bool) -> List a -> List a nubBy = nubBy' [] where @@ -487,22 +501,53 @@ else x :: nubBy' (x::acc) p xs +||| O(n^2). The nub function removes duplicate elements from a list. In +||| particular, it keeps only the first occurrence of each element. It is a +||| special case of nubBy, which allows the programmer to supply their own +||| equality test. +||| +||| ```idris example +||| nub (the (List _) [1,2,1,3]) +||| ``` nub : Eq a => List a -> List a nub = nubBy (==) +||| The deleteBy function behaves like delete, but takes a user-supplied equality predicate. deleteBy : (a -> a -> Bool) -> a -> List a -> List a deleteBy _ _ [] = [] deleteBy eq x (y::ys) = if x `eq` y then ys else y :: deleteBy eq x ys +||| `delete x` removes the first occurrence of `x` from its list argument. For +||| example, +||| +|||````idris example +|||delete 'a' ['b', 'a', 'n', 'a', 'n', 'a'] +|||```` +||| +||| It is a special case of deleteBy, which allows the programmer to supply +||| their own equality test. delete : (Eq a) => a -> List a -> List a delete = deleteBy (==) +||| The `\\` function is list difference (non-associative). In the result of +||| `xs \\ ys`, the first occurrence of each element of ys in turn (if any) has +||| been removed from `xs`, e.g., +||| +||| ```idris example +||| (([1,2] ++ [2,3]) \\ [1,2]) +||| ``` (\\) : (Eq a) => List a -> List a -> List a (\\) = foldl (flip delete) unionBy : (a -> a -> Bool) -> List a -> List a -> List a unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs +||| The union function returns the list union of the two lists. For example, +||| +||| ```idris example +||| union ['d', 'o', 'g'] ['c', 'o', 'w'] +||| ``` +||| union : (Eq a) => List a -> List a -> List a union = unionBy (==) @@ -512,6 +557,10 @@ ||| Given a list and a predicate, returns a pair consisting of the longest ||| prefix of the list that satisfies a predicate and the rest of the list. +||| +||| ```idris example +||| span (<3) [1,2,3,2,1] +||| ``` span : (a -> Bool) -> List a -> (List a, List a) span p [] = ([], []) span p (x::xs) = @@ -521,9 +570,21 @@ else ([], x::xs) +||| Given a list and a predicate, returns a pair consisting of the longest +||| prefix of the list that does not satisfy a predicate and the rest of the +||| list. +||| +||| ```idris example +||| break (>=3) [1,2,3,2,1] +||| ``` break : (a -> Bool) -> List a -> (List a, List a) break p = span (not . p) +||| Split on any elements that satisfy the given predicate. +||| +||| ```idris example +||| split (<2) [2,0,3,1,4] +||| ``` split : (a -> Bool) -> List a -> List (List a) split p xs = case break p xs of @@ -538,6 +599,11 @@ splitAt : (n : Nat) -> (xs : List a) -> (List a, List a) splitAt n xs = (take n xs, drop n xs) +||| The partition function takes a predicate a list and returns the pair of lists of elements which do and do not satisfy the predicate, respectively; e.g., +||| +||| ```idris example +||| partition (<3) [0, 1, 2, 3, 4, 5] +||| ``` partition : (a -> Bool) -> List a -> (List a, List a) partition p [] = ([], []) partition p (x::xs) = @@ -547,19 +613,43 @@ else (lefts, x::rights) +||| The inits function returns all initial segments of the argument, shortest +||| first. For example, +||| +||| ```idris example +||| inits [1,2,3] +||| ``` inits : List a -> List (List a) inits xs = [] :: case xs of [] => [] x :: xs' => map (x ::) (inits xs') +||| The tails function returns all final segments of the argument, longest +||| first. For example, +||| +||| ```idris example +||| tails [1,2,3] == [[1,2,3], [2,3], [3], []] +|||``` tails : List a -> List (List a) tails xs = xs :: case xs of [] => [] _ :: xs' => tails xs' +||| Split on the given element. +||| +||| ```idris example +||| splitOn 0 [1,0,2,0,0,3] +||| ``` +||| splitOn : Eq a => a -> List a -> List (List a) splitOn a = split (== a) +||| Replaces all occurences of the first argument with the second argument in a list. +||| +||| ```idris example +||| replaceOn '-' ',' ['1', '-', '2', '-', '3'] +||| ``` +||| replaceOn : Eq a => a -> a -> List a -> List a replaceOn a b l = map (\c => if c == a then b else c) l @@ -576,15 +666,26 @@ else False +||| The isPrefixOf function takes two lists and returns True iff the first list is a prefix of the second. isPrefixOf : Eq a => List a -> List a -> Bool isPrefixOf = isPrefixOfBy (==) isSuffixOfBy : (a -> a -> Bool) -> List a -> List a -> Bool isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right) +||| The isSuffixOf function takes two lists and returns True iff the first list is a suffix of the second. isSuffixOf : Eq a => List a -> List a -> Bool isSuffixOf = isSuffixOfBy (==) +||| The isInfixOf function takes two lists and returns True iff the first list is contained, wholly and intact, anywhere within the second. +||| +||| ```idris example +||| isInfixOf ['b','c'] ['a', 'b', 'c', 'd'] +||| ``` +||| ```idris example +||| isInfixOf ['b','d'] ['a', 'b', 'c', 'd'] +||| ``` +||| isInfixOf : Eq a => List a -> List a -> Bool isInfixOf n h = any (isPrefixOf n) (tails h) @@ -651,7 +752,7 @@ ||| The empty list is a right identity for append. appendNilRightNeutral : (l : List a) -> l ++ [] = l -appendNilRightNeutral [] = refl +appendNilRightNeutral [] = Refl appendNilRightNeutral (x::xs) = let inductiveHypothesis = appendNilRightNeutral xs in ?appendNilRightNeutralStepCase @@ -659,7 +760,7 @@ ||| Appending lists is associative. appendAssociative : (l : List a) -> (c : List a) -> (r : List a) -> l ++ (c ++ r) = (l ++ c) ++ r -appendAssociative [] c r = refl +appendAssociative [] c r = Refl appendAssociative (x::xs) c r = let inductiveHypothesis = appendAssociative xs c r in ?appendAssociativeStepCase @@ -668,7 +769,7 @@ ||| of the input lists. lengthAppend : (left : List a) -> (right : List a) -> length (left ++ right) = length left + length right -lengthAppend [] right = refl +lengthAppend [] right = Refl lengthAppend (x::xs) right = let inductiveHypothesis = lengthAppend xs right in ?lengthAppendStepCase @@ -676,7 +777,7 @@ ||| Mapping a function over a list doesn't change its length. mapPreservesLength : (f : a -> b) -> (l : List a) -> length (map f l) = length l -mapPreservesLength f [] = refl +mapPreservesLength f [] = Refl mapPreservesLength f (x::xs) = let inductiveHypothesis = mapPreservesLength f xs in ?mapPreservesLengthStepCase @@ -685,7 +786,7 @@ ||| to appending them and then mapping the function. mapDistributesOverAppend : (f : a -> b) -> (l : List a) -> (r : List a) -> map f (l ++ r) = map f l ++ map f r -mapDistributesOverAppend f [] r = refl +mapDistributesOverAppend f [] r = Refl mapDistributesOverAppend f (x::xs) r = let inductiveHypothesis = mapDistributesOverAppend f xs r in ?mapDistributesOverAppendStepCase @@ -693,7 +794,7 @@ ||| Mapping two functions is the same as mapping their composition. mapFusion : (f : b -> c) -> (g : a -> b) -> (l : List a) -> map f (map g l) = map (f . g) l -mapFusion f g [] = refl +mapFusion f g [] = Refl mapFusion f g (x::xs) = let inductiveHypothesis = mapFusion f g xs in ?mapFusionStepCase @@ -701,7 +802,7 @@ ||| No list contains an element of the empty list by any predicate. hasAnyByNilFalse : (p : a -> a -> Bool) -> (l : List a) -> hasAnyBy p [] l = False -hasAnyByNilFalse p [] = refl +hasAnyByNilFalse p [] = Refl hasAnyByNilFalse p (x::xs) = let inductiveHypothesis = hasAnyByNilFalse p xs in ?hasAnyByNilFalseStepCase diff --git a/libs/prelude/Prelude/Maybe.idr b/libs/prelude/Prelude/Maybe.idr --- a/libs/prelude/Prelude/Maybe.idr +++ b/libs/prelude/Prelude/Maybe.idr @@ -45,7 +45,7 @@ toMaybe False j = Nothing justInjective : {x : t} -> {y : t} -> (Just x = Just y) -> x = y -justInjective refl = refl +justInjective Refl = Refl ||| Convert a `Maybe a` value to an `a` value, using `neutral` in the case ||| that the `Maybe` value is `Nothing`. diff --git a/libs/prelude/Prelude/Nat.idr b/libs/prelude/Prelude/Nat.idr --- a/libs/prelude/Prelude/Nat.idr +++ b/libs/prelude/Prelude/Nat.idr @@ -22,7 +22,7 @@ %name Nat k,j,i,n,m instance Uninhabited (Z = S n) where - uninhabited refl impossible + uninhabited Refl impossible -------------------------------------------------------------------------------- -- Syntactic tests @@ -94,9 +94,9 @@ ||| @ m the larger number data LTE : (n, m : Nat) -> Type where ||| Zero is the smallest Nat - lteZero : LTE Z right + LTEZero : LTE Z right ||| If n <= m, then n + 1 <= m + 1 - lteSucc : LTE left right -> LTE (S left) (S right) + LTESucc : LTE left right -> LTE (S left) (S right) ||| Greater than or equal to total GTE : Nat -> Nat -> Type @@ -112,18 +112,18 @@ ||| A successor is never less than or equal zero succNotLTEzero : Not (S m `LTE` Z) -succNotLTEzero lteZero impossible +succNotLTEzero LTEZero impossible ||| If two numbers are ordered, their predecessors are too fromLteSucc : (S m `LTE` S n) -> (m `LTE` n) -fromLteSucc (lteSucc x) = x +fromLteSucc (LTESucc x) = x ||| A decision procedure for `LTE` isLTE : (m, n : Nat) -> Dec (m `LTE` n) -isLTE Z n = Yes lteZero +isLTE Z n = Yes LTEZero isLTE (S k) Z = No succNotLTEzero isLTE (S k) (S j) with (isLTE k j) - isLTE (S k) (S j) | (Yes prf) = Yes (lteSucc prf) + isLTE (S k) (S j) | (Yes prf) = Yes (LTESucc prf) isLTE (S k) (S j) | (No contra) = No (contra . fromLteSucc) ||| Boolean test than one Nat is less than or equal to another @@ -156,6 +156,14 @@ maximum (S n) Z = S n maximum (S n) (S m) = S (maximum n m) +||| Tail recursive cast Nat to Int +||| Note that this can overflow +toIntNat : Nat -> Int +toIntNat n = toIntNat' n 0 where + toIntNat' : Nat -> Int -> Int + toIntNat' Z x = x + toIntNat' (S n) x = toIntNat' n (x + 1) + -------------------------------------------------------------------------------- -- Type class instances -------------------------------------------------------------------------------- @@ -245,9 +253,7 @@ cast i = fromInteger (cast i) instance Cast Nat Int where - cast Z = 0 - cast (S n) = 1 + cast {to=Int} n - + cast = toIntNat -------------------------------------------------------------------------------- -- Auxilliary notions @@ -329,18 +335,18 @@ -- An informative comparison view -------------------------------------------------------------------------------- data CmpNat : Nat -> Nat -> Type where - cmpLT : (y : _) -> CmpNat x (x + S y) - cmpEQ : CmpNat x x - cmpGT : (x : _) -> CmpNat (y + S x) y + CmpLT : (y : _) -> CmpNat x (x + S y) + CmpEQ : CmpNat x x + CmpGT : (x : _) -> CmpNat (y + S x) y total cmp : (x, y : Nat) -> CmpNat x y -cmp Z Z = cmpEQ -cmp Z (S k) = cmpLT _ -cmp (S k) Z = cmpGT _ +cmp Z Z = CmpEQ +cmp Z (S k) = CmpLT _ +cmp (S k) Z = CmpGT _ cmp (S x) (S y) with (cmp x y) - cmp (S x) (S (x + (S k))) | cmpLT k = cmpLT k - cmp (S x) (S x) | cmpEQ = cmpEQ - cmp (S (y + (S k))) (S y) | cmpGT k = cmpGT k + cmp (S x) (S (x + (S k))) | CmpLT k = CmpLT k + cmp (S x) (S x) | CmpEQ = CmpEQ + cmp (S (y + (S k))) (S y) | CmpGT k = CmpGT k -------------------------------------------------------------------------------- -- Properties @@ -351,26 +357,26 @@ ||| S preserves equality total eqSucc : (left : Nat) -> (right : Nat) -> (p : left = right) -> S left = S right -eqSucc left _ refl = refl +eqSucc left _ Refl = Refl ||| S is injective total succInjective : (left : Nat) -> (right : Nat) -> (p : S left = S right) -> left = right -succInjective left _ refl = refl +succInjective left _ Refl = Refl -- Plus total plusZeroLeftNeutral : (right : Nat) -> 0 + right = right -plusZeroLeftNeutral right = refl +plusZeroLeftNeutral right = Refl total plusZeroRightNeutral : (left : Nat) -> left + 0 = left -plusZeroRightNeutral Z = refl +plusZeroRightNeutral Z = Refl plusZeroRightNeutral (S n) = let inductiveHypothesis = plusZeroRightNeutral n in ?plusZeroRightNeutralStepCase total plusSuccRightSucc : (left : Nat) -> (right : Nat) -> S (left + right) = left + (S right) -plusSuccRightSucc Z right = refl +plusSuccRightSucc Z right = Refl plusSuccRightSucc (S left) right = let inductiveHypothesis = plusSuccRightSucc left right in ?plusSuccRightSuccStepCase @@ -384,21 +390,21 @@ total plusAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) -> left + (centre + right) = (left + centre) + right -plusAssociative Z centre right = refl +plusAssociative Z centre right = Refl plusAssociative (S left) centre right = let inductiveHypothesis = plusAssociative left centre right in ?plusAssociativeStepCase total plusConstantRight : (left : Nat) -> (right : Nat) -> (c : Nat) -> (p : left = right) -> left + c = right + c -plusConstantRight left _ c refl = refl +plusConstantRight left _ c Refl = Refl total plusConstantLeft : (left : Nat) -> (right : Nat) -> (c : Nat) -> (p : left = right) -> c + left = c + right -plusConstantLeft left _ c refl = refl +plusConstantLeft left _ c Refl = Refl total plusOneSucc : (right : Nat) -> 1 + right = S right -plusOneSucc n = refl +plusOneSucc n = Refl total plusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) -> (p : left + right = left + right') -> right = right' @@ -423,24 +429,24 @@ -- Mult total multZeroLeftZero : (right : Nat) -> Z * right = Z -multZeroLeftZero right = refl +multZeroLeftZero right = Refl total multZeroRightZero : (left : Nat) -> left * Z = Z -multZeroRightZero Z = refl +multZeroRightZero Z = Refl multZeroRightZero (S left) = let inductiveHypothesis = multZeroRightZero left in ?multZeroRightZeroStepCase total multRightSuccPlus : (left : Nat) -> (right : Nat) -> left * (S right) = left + (left * right) -multRightSuccPlus Z right = refl +multRightSuccPlus Z right = Refl multRightSuccPlus (S left) right = let inductiveHypothesis = multRightSuccPlus left right in ?multRightSuccPlusStepCase total multLeftSuccPlus : (left : Nat) -> (right : Nat) -> (S left) * right = right + (left * right) -multLeftSuccPlus left right = refl +multLeftSuccPlus left right = Refl total multCommutative : (left : Nat) -> (right : Nat) -> left * right = right * left @@ -451,33 +457,33 @@ total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) -> left * (centre + right) = (left * centre) + (left * right) -multDistributesOverPlusRight Z centre right = refl +multDistributesOverPlusRight Z centre right = Refl multDistributesOverPlusRight (S left) centre right = let inductiveHypothesis = multDistributesOverPlusRight left centre right in ?multDistributesOverPlusRightStepCase total multDistributesOverPlusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) -> (left + centre) * right = (left * right) + (centre * right) -multDistributesOverPlusLeft Z centre right = refl +multDistributesOverPlusLeft Z centre right = Refl multDistributesOverPlusLeft (S left) centre right = let inductiveHypothesis = multDistributesOverPlusLeft left centre right in ?multDistributesOverPlusLeftStepCase total multAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) -> left * (centre * right) = (left * centre) * right -multAssociative Z centre right = refl +multAssociative Z centre right = Refl multAssociative (S left) centre right = let inductiveHypothesis = multAssociative left centre right in ?multAssociativeStepCase total multOneLeftNeutral : (right : Nat) -> 1 * right = right -multOneLeftNeutral Z = refl +multOneLeftNeutral Z = Refl multOneLeftNeutral (S right) = let inductiveHypothesis = multOneLeftNeutral right in ?multOneLeftNeutralStepCase total multOneRightNeutral : (left : Nat) -> left * 1 = left -multOneRightNeutral Z = refl +multOneRightNeutral Z = Refl multOneRightNeutral (S left) = let inductiveHypothesis = multOneRightNeutral left in ?multOneRightNeutralStepCase @@ -485,53 +491,53 @@ -- Minus total minusSuccSucc : (left : Nat) -> (right : Nat) -> (S left) - (S right) = left - right -minusSuccSucc left right = refl +minusSuccSucc left right = Refl total minusZeroLeft : (right : Nat) -> 0 - right = Z -minusZeroLeft right = refl +minusZeroLeft right = Refl total minusZeroRight : (left : Nat) -> left - 0 = left -minusZeroRight Z = refl -minusZeroRight (S left) = refl +minusZeroRight Z = Refl +minusZeroRight (S left) = Refl total minusZeroN : (n : Nat) -> Z = n - n -minusZeroN Z = refl +minusZeroN Z = Refl minusZeroN (S n) = minusZeroN n total minusOneSuccN : (n : Nat) -> S Z = (S n) - n -minusOneSuccN Z = refl +minusOneSuccN Z = Refl minusOneSuccN (S n) = minusOneSuccN n total minusSuccOne : (n : Nat) -> S n - 1 = n -minusSuccOne Z = refl -minusSuccOne (S n) = refl +minusSuccOne Z = Refl +minusSuccOne (S n) = Refl total minusPlusZero : (n : Nat) -> (m : Nat) -> n - (n + m) = Z -minusPlusZero Z m = refl +minusPlusZero Z m = Refl minusPlusZero (S n) m = minusPlusZero n m total minusMinusMinusPlus : (left : Nat) -> (centre : Nat) -> (right : Nat) -> left - centre - right = left - (centre + right) -minusMinusMinusPlus Z Z right = refl -minusMinusMinusPlus (S left) Z right = refl -minusMinusMinusPlus Z (S centre) right = refl +minusMinusMinusPlus Z Z right = Refl +minusMinusMinusPlus (S left) Z right = Refl +minusMinusMinusPlus Z (S centre) right = Refl minusMinusMinusPlus (S left) (S centre) right = let inductiveHypothesis = minusMinusMinusPlus left centre right in ?minusMinusMinusPlusStepCase total plusMinusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) -> (left + right) - (left + right') = right - right' -plusMinusLeftCancel Z right right' = refl +plusMinusLeftCancel Z right right' = Refl plusMinusLeftCancel (S left) right right' = let inductiveHypothesis = plusMinusLeftCancel left right right' in ?plusMinusLeftCancelStepCase total multDistributesOverMinusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) -> (left - centre) * right = (left * right) - (centre * right) -multDistributesOverMinusLeft Z Z right = refl +multDistributesOverMinusLeft Z Z right = Refl multDistributesOverMinusLeft (S left) Z right = ?multDistributesOverMinusLeftBaseCase -multDistributesOverMinusLeft Z (S centre) right = refl +multDistributesOverMinusLeft Z (S centre) right = Refl multDistributesOverMinusLeft (S left) (S centre) right = let inductiveHypothesis = multDistributesOverMinusLeft left centre right in ?multDistributesOverMinusLeftStepCase @@ -544,7 +550,7 @@ -- Power total powerSuccPowerLeft : (base : Nat) -> (exp : Nat) -> power base (S exp) = base * (power base exp) -powerSuccPowerLeft base exp = refl +powerSuccPowerLeft base exp = Refl total multPowerPowerPlus : (base : Nat) -> (exp : Nat) -> (exp' : Nat) -> (power base exp) * (power base exp') = power base (exp + exp') @@ -554,22 +560,22 @@ ?multPowerPowerPlusStepCase total powerZeroOne : (base : Nat) -> power base 0 = S Z -powerZeroOne base = refl +powerZeroOne base = Refl total powerOneNeutral : (base : Nat) -> power base 1 = base -powerOneNeutral Z = refl +powerOneNeutral Z = Refl powerOneNeutral (S base) = let inductiveHypothesis = powerOneNeutral base in ?powerOneNeutralStepCase total powerOneSuccOne : (exp : Nat) -> power 1 exp = S Z -powerOneSuccOne Z = refl +powerOneSuccOne Z = Refl powerOneSuccOne (S exp) = let inductiveHypothesis = powerOneSuccOne exp in ?powerOneSuccOneStepCase total powerSuccSuccMult : (base : Nat) -> power base 2 = mult base base -powerSuccSuccMult Z = refl +powerSuccSuccMult Z = Refl powerSuccSuccMult (S base) = let inductiveHypothesis = powerSuccSuccMult base in ?powerSuccSuccMultStepCase @@ -583,11 +589,11 @@ -- Pred total predSucc : (n : Nat) -> pred (S n) = n -predSucc n = refl +predSucc n = Refl total minusSuccPred : (left : Nat) -> (right : Nat) -> left - (S right) = pred (left - right) -minusSuccPred Z right = refl +minusSuccPred Z right = Refl minusSuccPred (S left) Z = let inductiveHypothesis = minusSuccPred left Z in ?minusSuccPredStepCase @@ -598,125 +604,125 @@ -- boolElim total boolElimSuccSucc : (cond : Bool) -> (t : Nat) -> (f : Nat) -> S (boolElim cond t f) = boolElim cond (S t) (S f) -boolElimSuccSucc True t f = refl -boolElimSuccSucc False t f = refl +boolElimSuccSucc True t f = Refl +boolElimSuccSucc False t f = Refl total boolElimPlusPlusLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) -> left + (boolElim cond t f) = boolElim cond (left + t) (left + f) -boolElimPlusPlusLeft True left t f = refl -boolElimPlusPlusLeft False left t f = refl +boolElimPlusPlusLeft True left t f = Refl +boolElimPlusPlusLeft False left t f = Refl total boolElimPlusPlusRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) -> (boolElim cond t f) + right = boolElim cond (t + right) (f + right) -boolElimPlusPlusRight True right t f = refl -boolElimPlusPlusRight False right t f = refl +boolElimPlusPlusRight True right t f = Refl +boolElimPlusPlusRight False right t f = Refl total boolElimMultMultLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) -> left * (boolElim cond t f) = boolElim cond (left * t) (left * f) -boolElimMultMultLeft True left t f = refl -boolElimMultMultLeft False left t f = refl +boolElimMultMultLeft True left t f = Refl +boolElimMultMultLeft False left t f = Refl total boolElimMultMultRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) -> (boolElim cond t f) * right = boolElim cond (t * right) (f * right) -boolElimMultMultRight True right t f = refl -boolElimMultMultRight False right t f = refl +boolElimMultMultRight True right t f = Refl +boolElimMultMultRight False right t f = Refl -- Orders total lteNTrue : (n : Nat) -> lte n n = True -lteNTrue Z = refl +lteNTrue Z = Refl lteNTrue (S n) = lteNTrue n -total lteSuccZeroFalse : (n : Nat) -> lte (S n) Z = False -lteSuccZeroFalse Z = refl -lteSuccZeroFalse (S n) = refl +total LTESuccZeroFalse : (n : Nat) -> lte (S n) Z = False +LTESuccZeroFalse Z = Refl +LTESuccZeroFalse (S n) = Refl -- Minimum and maximum total maximumAssociative : (l,c,r : Nat) -> maximum l (maximum c r) = maximum (maximum l c) r -maximumAssociative Z c r = refl -maximumAssociative (S k) Z r = refl -maximumAssociative (S k) (S j) Z = refl -maximumAssociative (S k) (S j) (S i) = rewrite maximumAssociative k j i in refl +maximumAssociative Z c r = Refl +maximumAssociative (S k) Z r = Refl +maximumAssociative (S k) (S j) Z = Refl +maximumAssociative (S k) (S j) (S i) = rewrite maximumAssociative k j i in Refl total maximumCommutative : (l, r : Nat) -> maximum l r = maximum r l -maximumCommutative Z Z = refl -maximumCommutative Z (S k) = refl -maximumCommutative (S k) Z = refl -maximumCommutative (S k) (S j) = rewrite maximumCommutative k j in refl +maximumCommutative Z Z = Refl +maximumCommutative Z (S k) = Refl +maximumCommutative (S k) Z = Refl +maximumCommutative (S k) (S j) = rewrite maximumCommutative k j in Refl total maximumIdempotent : (n : Nat) -> maximum n n = n -maximumIdempotent Z = refl +maximumIdempotent Z = Refl maximumIdempotent (S k) = cong (maximumIdempotent k) total minimumAssociative : (l,c,r : Nat) -> minimum l (minimum c r) = minimum (minimum l c) r -minimumAssociative Z c r = refl -minimumAssociative (S k) Z r = refl -minimumAssociative (S k) (S j) Z = refl -minimumAssociative (S k) (S j) (S i) = rewrite minimumAssociative k j i in refl +minimumAssociative Z c r = Refl +minimumAssociative (S k) Z r = Refl +minimumAssociative (S k) (S j) Z = Refl +minimumAssociative (S k) (S j) (S i) = rewrite minimumAssociative k j i in Refl total minimumCommutative : (l, r : Nat) -> minimum l r = minimum r l -minimumCommutative Z Z = refl -minimumCommutative Z (S k) = refl -minimumCommutative (S k) Z = refl -minimumCommutative (S k) (S j) = rewrite minimumCommutative k j in refl +minimumCommutative Z Z = Refl +minimumCommutative Z (S k) = Refl +minimumCommutative (S k) Z = Refl +minimumCommutative (S k) (S j) = rewrite minimumCommutative k j in Refl total minimumIdempotent : (n : Nat) -> minimum n n = n -minimumIdempotent Z = refl +minimumIdempotent Z = Refl minimumIdempotent (S k) = cong (minimumIdempotent k) total minimumZeroZeroRight : (right : Nat) -> minimum 0 right = Z -minimumZeroZeroRight Z = refl +minimumZeroZeroRight Z = Refl minimumZeroZeroRight (S right) = minimumZeroZeroRight right total minimumZeroZeroLeft : (left : Nat) -> minimum left 0 = Z -minimumZeroZeroLeft Z = refl -minimumZeroZeroLeft (S left) = refl +minimumZeroZeroLeft Z = Refl +minimumZeroZeroLeft (S left) = Refl total minimumSuccSucc : (left : Nat) -> (right : Nat) -> minimum (S left) (S right) = S (minimum left right) -minimumSuccSucc Z Z = refl -minimumSuccSucc (S left) Z = refl -minimumSuccSucc Z (S right) = refl +minimumSuccSucc Z Z = Refl +minimumSuccSucc (S left) Z = Refl +minimumSuccSucc Z (S right) = Refl minimumSuccSucc (S left) (S right) = let inductiveHypothesis = minimumSuccSucc left right in ?minimumSuccSuccStepCase total maximumZeroNRight : (right : Nat) -> maximum Z right = right -maximumZeroNRight Z = refl -maximumZeroNRight (S right) = refl +maximumZeroNRight Z = Refl +maximumZeroNRight (S right) = Refl total maximumZeroNLeft : (left : Nat) -> maximum left Z = left -maximumZeroNLeft Z = refl -maximumZeroNLeft (S left) = refl +maximumZeroNLeft Z = Refl +maximumZeroNLeft (S left) = Refl total maximumSuccSucc : (left : Nat) -> (right : Nat) -> S (maximum left right) = maximum (S left) (S right) -maximumSuccSucc Z Z = refl -maximumSuccSucc (S left) Z = refl -maximumSuccSucc Z (S right) = refl +maximumSuccSucc Z Z = Refl +maximumSuccSucc (S left) Z = Refl +maximumSuccSucc Z (S right) = Refl maximumSuccSucc (S left) (S right) = let inductiveHypothesis = maximumSuccSucc left right in ?maximumSuccSuccStepCase total sucMaxL : (l : Nat) -> maximum (S l) l = (S l) -sucMaxL Z = refl +sucMaxL Z = Refl sucMaxL (S l) = cong (sucMaxL l) total sucMaxR : (l : Nat) -> maximum l (S l) = (S l) -sucMaxR Z = refl +sucMaxR Z = Refl sucMaxR (S l) = cong (sucMaxR l) total sucMinL : (l : Nat) -> minimum (S l) l = l -sucMinL Z = refl +sucMinL Z = Refl sucMinL (S l) = cong (sucMinL l) total sucMinR : (l : Nat) -> minimum l (S l) = l -sucMinR Z = refl +sucMinR Z = Refl sucMinR (S l) = cong (sucMinR l) -- div and mod total modZeroZero : (n : Nat) -> mod 0 n = Z -modZeroZero Z = refl -modZeroZero (S n) = refl +modZeroZero Z = Refl +modZeroZero (S n) = Refl -------------------------------------------------------------------------------- -- Proofs diff --git a/libs/prelude/Prelude/Pairs.idr b/libs/prelude/Prelude/Pairs.idr --- a/libs/prelude/Prelude/Pairs.idr +++ b/libs/prelude/Prelude/Pairs.idr @@ -9,27 +9,27 @@ ||| Dependent pair where the first field is erased. data Exists : (P : a -> Type) -> Type where - evidence : .(x : a) -> (pf : P x) -> Exists P + Evidence : .(x : a) -> (pf : P x) -> Exists P ||| Dependent pair where the second field is erased. data Subset : (a : Type) -> (P : a -> Type) -> Type where - element : (x : a) -> .(pf : P x) -> Subset a P + Element : (x : a) -> .(pf : P x) -> Subset a P -- Monomorphic projections namespace Exists getWitness : Exists {a} P -> a - getWitness (evidence x pf) = x + getWitness (Evidence x pf) = x getProof : (x : Exists {a} P) -> P (getWitness x) - getProof (evidence x pf) = pf + getProof (Evidence x pf) = pf namespace Subset getWitness : Subset a P -> a - getWitness (element x pf) = x + getWitness (Element x pf) = x getProof : (x : Subset a P) -> P (getWitness x) - getProof (element x pf) = pf + getProof (Element x pf) = pf namespace Sigma getWitness : Sigma a P -> a diff --git a/libs/prelude/Prelude/Stream.idr b/libs/prelude/Prelude/Stream.idr --- a/libs/prelude/Prelude/Stream.idr +++ b/libs/prelude/Prelude/Stream.idr @@ -57,13 +57,25 @@ zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys +||| Combine three streams by applying a function element-wise along them +zipWith3 : (a -> b -> c -> d) -> Stream a -> Stream b -> Stream c -> Stream d +zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs + ||| Create a stream of pairs from two streams zip : Stream a -> Stream b -> Stream (a, b) zip = zipWith (\x,y => (x,y)) +||| Combine three streams into a stream of tuples elementwise +zip3 : Stream a -> Stream b -> Stream c -> Stream (a, b, c) +zip3 = zipWith3 (\x,y,z => (x,y,z)) + ||| Create a pair of streams from a stream of pairs unzip : Stream (a, b) -> (Stream a, Stream b) unzip xs = (map fst xs, map snd xs) + +||| Split a stream of three-element tuples into three streams +unzip3 : Stream (a, b, c) -> (Stream a, Stream b, Stream c) +unzip3 xs = (map (\(x,_,_) => x) xs, map (\(_,x,_) => x) xs, map (\(_,_,x) => x) xs) ||| Return the diagonal elements of a stream of streams diag : Stream (Stream a) -> Stream a diff --git a/libs/prelude/Prelude/Strings.idr b/libs/prelude/Prelude/Strings.idr --- a/libs/prelude/Prelude/Strings.idr +++ b/libs/prelude/Prelude/Strings.idr @@ -74,11 +74,11 @@ StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs) ||| Version of 'strHead' that statically verifies that the string is not empty. -strHead' : (x : String) -> so (not (x == "")) -> Char +strHead' : (x : String) -> So (not (x == "")) -> Char strHead' x p = assert_total $ prim__strHead x ||| Version of 'strTail' that statically verifies that the string is not empty. -strTail' : (x : String) -> so (not (x == "")) -> String +strTail' : (x : String) -> So (not (x == "")) -> String strTail' x p = assert_total $ prim__strTail x -- we need the 'believe_me' because the operations are primitives diff --git a/libs/prelude/Prelude/Uninhabited.idr b/libs/prelude/Prelude/Uninhabited.idr --- a/libs/prelude/Prelude/Uninhabited.idr +++ b/libs/prelude/Prelude/Uninhabited.idr @@ -6,9 +6,9 @@ class Uninhabited t where ||| If I have a t, I've had a contradiction ||| @ t the uninhabited type - total uninhabited : t -> _|_ + total uninhabited : t -> Void -instance Uninhabited _|_ where +instance Uninhabited Void where uninhabited a = a ||| Use an absurd assumption to discharge a proof obligation @@ -16,4 +16,4 @@ ||| @ a the goal type ||| @ h the contradictory hypothesis absurd : Uninhabited t => (h : t) -> a -absurd h = FalseElim (uninhabited h) +absurd h = void (uninhabited h) diff --git a/libs/prelude/Prelude/Vect.idr b/libs/prelude/Prelude/Vect.idr --- a/libs/prelude/Prelude/Vect.idr +++ b/libs/prelude/Prelude/Vect.idr @@ -37,8 +37,8 @@ ||| Show that the length function on vectors in fact calculates the length private lengthCorrect : (n : Nat) -> (xs : Vect n a) -> length xs = n -lengthCorrect Z [] = refl -lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in refl +lengthCorrect Z [] = Refl +lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in Refl -------------------------------------------------------------------------------- -- Indexing into vectors @@ -64,35 +64,36 @@ ||| Extract a particular element from a vector index : Fin n -> Vect n a -> a -index fZ (x::xs) = x -index (fS k) (x::xs) = index k xs -index fZ [] impossible +index FZ (x::xs) = x +index (FS k) (x::xs) = index k xs +index FZ [] impossible + ||| Insert an element at a particular index insertAt : Fin (S n) -> a -> Vect n a -> Vect (S n) a -insertAt fZ y xs = y :: xs -insertAt (fS k) y (x::xs) = x :: insertAt k y xs -insertAt (fS k) y [] = absurd k +insertAt FZ y xs = y :: xs +insertAt (FS k) y (x::xs) = x :: insertAt k y xs +insertAt (FS k) y [] = absurd k ||| Construct a new vector consisting of all but the indicated element deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a -deleteAt fZ (x::xs) = xs -deleteAt {n = S m} (fS k) (x::xs) = x :: deleteAt k xs -deleteAt {n = Z} (fS k) (x::xs) = absurd k -deleteAt _ [] impossible +deleteAt FZ (x::xs) = xs +deleteAt {n = S m} (FS k) (x::xs) = x :: deleteAt k xs +deleteAt {n = Z} (FS k) (x::xs) = absurd k +deleteAt _ [] impossible ||| Replace an element at a particlar index with another replaceAt : Fin n -> t -> Vect n t -> Vect n t -replaceAt fZ y (x::xs) = y :: xs -replaceAt (fS k) y (x::xs) = x :: replaceAt k y xs +replaceAt FZ y (x::xs) = y :: xs +replaceAt (FS k) y (x::xs) = x :: replaceAt k y xs ||| Replace the element at a particular index with the result of applying a function to it ||| @ i the index to replace at ||| @ f the update function ||| @ xs the vector to replace in updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t -updateAt fZ f (x::xs) = f x :: xs -updateAt (fS k) f (x::xs) = x :: updateAt k f xs +updateAt FZ f (x::xs) = f x :: xs +updateAt (FS k) f (x::xs) = x :: updateAt k f xs -------------------------------------------------------------------------------- -- Subvectors @@ -101,32 +102,51 @@ ||| Get the first m elements of a Vect ||| @ m the number of elements to take take : (n : Nat) -> Vect (n + m) a -> Vect n a -take Z xs = [] +take Z xs = [] take (S k) (x :: xs) = x :: take k xs ||| Remove the first m elements of a Vect ||| @ m the number of elements to remove drop : (n : Nat) -> Vect (n + m) a -> Vect m a -drop Z xs = xs +drop Z xs = xs drop (S k) (x :: xs) = drop k xs +||| Take the longest prefix of a Vect such that all elements satisfy some +||| Boolean predicate. +||| +||| @ p the predicate +takeWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a) +takeWhile p [] = (_ ** []) +takeWhile p (x::xs) = + let (len ** ys) = takeWhile p xs + in if p x then + (S len ** x :: ys) + else + (_ ** []) + +||| Remove the longest prefix of a Vect such that all removed elements satisfy some +||| Boolean predicate. +||| +||| @ p the predicate +dropWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a) +dropWhile p [] = (_ ** []) +dropWhile p (x::xs) = + if p x then + dropWhile p xs + else + (_ ** x::xs) + -------------------------------------------------------------------------------- -- Transformations -------------------------------------------------------------------------------- ||| Reverse the order of the elements of a vector -total reverse : {n : Nat} -> Vect n a -> Vect n a -reverse {n} xs = reverse' [] (plusZeroRightNeutral n) xs - where - total reverse' : {m, j, l : Nat} -> - Vect m a -> (j + m = l) -> Vect j a -> Vect l a - reverse' {m} {j = Z } {l} acc prf [] ?= acc - reverse' {m} {j = S k} {l} acc prf (x::xs) = - let prf1 : (m + (S k) = l) = rewrite plusCommutative m (S k) in prf in - let prf2 : (S (m + k) = l) = rewrite plusSuccRightSucc m k in prf1 in - let prf3 : (S (k + m) = l) = rewrite plusCommutative k m in prf2 in - let prf4 : (k + (S m) = l) = rewrite sym $ plusSuccRightSucc k m in prf3 in - reverse' (x::acc) prf4 xs +reverse : Vect n a -> Vect n a +reverse xs = go [] xs + where go : Vect n a -> Vect m a -> Vect (n+m) a + go {n} acc [] = rewrite plusZeroRightNeutral n in acc + go {n} {m=S m} acc (x :: xs) = rewrite sym $ plusSuccRightSucc n m + in go (x::acc) xs ||| Alternate an element between the other elements of a vector ||| @ sep the element to intersperse @@ -136,8 +156,9 @@ intersperse sep (x::xs) = x :: intersperse' sep xs where intersperse' : a -> Vect n a -> Vect (n + n) a - intersperse' sep [] = [] - intersperse' sep (x::xs) ?= sep :: x :: intersperse' sep xs + intersperse' sep [] = [] + intersperse' {n=S n} sep (x::xs) = rewrite sym $ plusSuccRightSucc n n + in sep :: x :: intersperse' sep xs -------------------------------------------------------------------------------- -- Conversion from list (toList is provided by Foldable) @@ -147,7 +168,7 @@ fromList' : Vect n a -> (l : List a) -> Vect (length l + n) a fromList' ys [] = ys fromList' {n} ys (x::xs) = - rewrite (plusSuccRightSucc (length xs) n) ==> + rewrite (plusSuccRightSucc (length xs) n) ==> Vect (plus (length xs) (S n)) a in fromList' (x::ys) xs @@ -184,16 +205,31 @@ zipWith f [] [] = [] zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys +||| Combine three equal-length vectors into a vector with some function +zipWith3 : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d +zipWith3 f [] [] [] = [] +zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs + ||| Combine two equal-length vectors pairwise zip : Vect n a -> Vect n b -> Vect n (a, b) -zip = zipWith (\x => \y => (x,y)) +zip = zipWith (\x,y => (x,y)) +||| Combine three equal-length vectors elementwise into a vector of tuples +zip3 : Vect n a -> Vect n b -> Vect n c -> Vect n (a, b, c) +zip3 = zipWith3 (\x,y,z => (x,y,z)) + ||| Convert a vector of pairs to a pair of vectors unzip : Vect n (a, b) -> (Vect n a, Vect n b) unzip [] = ([], []) unzip ((l, r)::xs) with (unzip xs) | (lefts, rights) = (l::lefts, r::rights) +||| Convert a vector of three-tuples to a triplet of vectors +unzip3 : Vect n (a, b, c) -> (Vect n a, Vect n b, Vect n c) +unzip3 [] = ([], [], []) +unzip3 ((l,c,r)::xs) with (unzip3 xs) + | (lefts, centers, rights) = (l::lefts, c::centers, r::rights) + -------------------------------------------------------------------------------- -- Equality -------------------------------------------------------------------------------- @@ -212,7 +248,7 @@ -------------------------------------------------------------------------------- instance Ord a => Ord (Vect n a) where - compare [] [] = EQ + compare [] [] = EQ compare (x::xs) (y::ys) = if x /= y then compare x y @@ -228,16 +264,25 @@ map f [] = [] map f (x::xs) = f x :: map f xs --- XXX: causes Idris to enter an infinite loop when type checking in the REPL ---mapMaybe : (a -> Maybe b) -> Vect n a -> (p ** Vect b p) ---mapMaybe f [] = (_ ** []) ---mapMaybe f (x::xs) = mapMaybe' (f x) --- XXX: working around the type restrictions on case statements --- where --- mapMaybe' : (Maybe b) -> (n ** Vect b n) -> (p ** Vect b p) --- mapMaybe' Nothing (n ** tail) = (n ** tail) --- mapMaybe' (Just j) (n ** tail) = (S n ** j::tail) +||| Map a partial function across a vector, returning those elements for which +||| the function had a value. +||| +||| The first projection of the resulting pair (ie the length) will always be +||| at most the length of the input vector. This is not, however, guaranteed +||| by the type. +||| +||| @ f the partial function (expressed by returning `Maybe`) +||| @ xs the vector to check for results +mapMaybe : (f : a -> Maybe b) -> (xs : Vect n a) -> (m : Nat ** Vect m b) +mapMaybe f [] = (_ ** []) +mapMaybe f (x::xs) = + let (len ** ys) = mapMaybe f xs + in case f x of + Just y => (S len ** y :: ys) + Nothing => ( len ** ys) + + -------------------------------------------------------------------------------- -- Folds -------------------------------------------------------------------------------- @@ -396,6 +441,15 @@ nub : Eq a => Vect n a -> (p ** Vect p a) nub = nubBy (==) +deleteBy : (a -> a -> Bool) -> a -> Vect n a -> (p ** Vect p a) +deleteBy _ _ [] = (_ ** []) +deleteBy eq x (y::ys) = + let (len ** zs) = deleteBy eq x ys + in if x `eq` y then (_ ** ys) else (S len ** y ::zs) + +delete : (Eq a) => a -> Vect n a -> (p ** Vect p a) +delete = deleteBy (==) + -------------------------------------------------------------------------------- -- Splitting and breaking lists -------------------------------------------------------------------------------- @@ -408,6 +462,15 @@ splitAt : (n : Nat) -> (xs : Vect (n + m) a) -> (Vect n a, Vect m a) splitAt n xs = (take n xs, drop n xs) +partition : (a -> Bool) -> Vect n a -> ((p ** Vect p a), (q ** Vect q a)) +partition p [] = ((_ ** []), (_ ** [])) +partition p (x::xs) = + let ((leftLen ** lefts), (rightLen ** rights)) = partition p xs in + if p x then + ((S leftLen ** x::lefts), (rightLen ** rights)) + else + ((leftLen ** lefts), (S rightLen ** x::rights)) + -------------------------------------------------------------------------------- -- Predicates -------------------------------------------------------------------------------- @@ -451,18 +514,18 @@ | (_ ** tail) = (_ ** j::tail) diag : Vect n (Vect n a) -> Vect n a -diag [] = [] +diag [] = [] diag ((x::xs)::xss) = x :: diag (map tail xss) range : Vect n (Fin n) -range {n=Z} = [] -range {n=S _} = fZ :: map fS range +range {n=Z} = [] +range {n=S _} = FZ :: map FS range ||| Transpose a Vect of Vects, turning rows into columns and vice versa. ||| ||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`. transpose : Vect m (Vect n a) -> Vect n (Vect m a) -transpose [] = replicate _ [] +transpose [] = replicate _ [] transpose (x :: xs) = zipWith (::) x (transpose xs) -------------------------------------------------------------------------------- @@ -470,32 +533,16 @@ -------------------------------------------------------------------------------- vectConsCong : (x : a) -> (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> (x :: xs = x :: ys) -vectConsCong x xs xs refl = refl +vectConsCong x xs xs Refl = Refl vectNilRightNeutral : (xs : Vect n a) -> xs ++ [] = xs -vectNilRightNeutral [] = refl +vectNilRightNeutral [] = Refl vectNilRightNeutral (x :: xs) = vectConsCong _ _ _ (vectNilRightNeutral xs) vectAppendAssociative : (x : Vect xLen a) -> (y : Vect yLen a) -> (z : Vect zLen a) -> x ++ (y ++ z) = (x ++ y) ++ z -vectAppendAssociative [] y z = refl +vectAppendAssociative [] y z = Refl vectAppendAssociative (x :: xs) ys zs = vectConsCong _ _ _ (vectAppendAssociative xs ys zs) --------------------------------------------------------------------------------- --- Proofs --------------------------------------------------------------------------------- - -Prelude.Vect.reverse'_lemma_1 = proof { - intros; - rewrite prf; - rewrite sym (plusZeroRightNeutral m); - exact value; -} - -Prelude.Vect.intersperse'_lemma_1 = proof { - intros; - rewrite (plusSuccRightSucc n1 n1); - trivial; -} diff --git a/llvm/Makefile b/llvm/Makefile deleted file mode 100644 --- a/llvm/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -include ../config.mk - -PKG_CONFIG_CFLAGS:=$(shell (pkg-config --version >/dev/null 2>&1) && pkg-config --cflags bdw-gc) -CFLAGS:=-Wextra -fPIC -Wno-unused-parameter $(PKG_CONFIG_CFLAGS) $(CFLAGS) -SOURCES=defs.c -OBJECTS=$(SOURCES:.c=.o) -LIB=libidris_rts.a - -build: $(SOURCES) $(LIB) - -$(LIB): $(OBJECTS) - ar r $@ $(OBJECTS) - ranlib $@ - -.c.o: - $(CC) -c $(CFLAGS) $< -o $@ - -install: $(LIB) - mkdir -p $(TARGET) - install $(LIB) $(TARGET) - -clean: - rm -f $(OBJECTS) $(LIB) - -.PHONY: build install clean diff --git a/llvm/defs.c b/llvm/defs.c deleted file mode 100644 --- a/llvm/defs.c +++ /dev/null @@ -1,182 +0,0 @@ -#include -#include -#include -#include -#include -#include - -extern char** environ; - -void putStr(const char *str) { - 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) */ - mpz_mul_2exp(n, n, 32); /* n <<= 32 */ - mpz_add_ui(n, n, (unsigned int)ull); /* n += (unsigned int)ull */ -} - -void mpz_init_set_sll(mpz_t n, long long sll) -{ - mpz_init_set_si(n, (int)(sll >> 32)); /* n = (int)sll >> 32 */ - mpz_mul_2exp(n, n, 32 ); /* n <<= 32 */ - mpz_add_ui(n, n, (unsigned int)sll); /* n += (unsigned int)sll */ -} - -void mpz_set_sll(mpz_t n, long long sll) -{ - mpz_set_si(n, (int)(sll >> 32)); /* n = (int)sll >> 32 */ - mpz_mul_2exp(n, n, 32 ); /* n <<= 32 */ - mpz_add_ui(n, n, (unsigned int)sll); /* n += (unsigned int)sll */ -} - -unsigned long long mpz_get_ull(mpz_t n) -{ - unsigned int lo, hi; - mpz_t tmp; - - mpz_init( tmp ); - mpz_mod_2exp( tmp, n, 64 ); /* tmp = (lower 64 bits of n) */ - - lo = mpz_get_ui( tmp ); /* lo = tmp & 0xffffffff */ - mpz_div_2exp( tmp, tmp, 32 ); /* tmp >>= 32 */ - hi = mpz_get_ui( tmp ); /* hi = tmp & 0xffffffff */ - - mpz_clear( tmp ); - - return (((unsigned long long)hi) << 32) + lo; -} - -char *__idris_strCons(char c, char *s) { - size_t len = strlen(s); - char *result = GC_malloc_atomic(len+2); - result[0] = c; - memcpy(result+1, s, len); - result[len+1] = 0; - return result; -} - -#define BUFSIZE 256 -char *__idris_readStr(FILE* h) { -// Modified from 'safe-fgets.c' in the gdb distribution. -// (see http://www.gnu.org/software/gdb/current/) - char *line_ptr; - char* line_buf = (char *) GC_malloc (BUFSIZE); - int line_buf_size = BUFSIZE; - - /* points to last byte */ - line_ptr = line_buf + line_buf_size - 1; - - /* so we can see if fgets put a 0 there */ - *line_ptr = 1; - if (fgets (line_buf, line_buf_size, h) == 0) - return ""; - - /* we filled the buffer? */ - while (line_ptr[0] == 0 && line_ptr[-1] != '\n') - { - /* Make the buffer bigger and read more of the line */ - line_buf_size += BUFSIZE; - line_buf = (char *) GC_realloc (line_buf, line_buf_size); - - /* points to last byte again */ - line_ptr = line_buf + line_buf_size - 1; - /* so we can see if fgets put a 0 there */ - *line_ptr = 1; - - if (fgets (line_buf + line_buf_size - BUFSIZE - 1, BUFSIZE + 1, h) == 0) - return ""; - } - - return line_buf; -} - -void* fileOpen(char* name, char* mode) { - FILE* f = fopen(name, mode); - return (void*)f; -} - -void fileClose(void* h) { - FILE* f = (FILE*)h; - fclose(f); -} - -int fileEOF(void* h) { - FILE* f = (FILE*)h; - return feof(f); -} - -int fileError(void* h) { - FILE* f = (FILE*)h; - return ferror(f); -} - -void fputStr(void* h, char* str) { - FILE* f = (FILE*)h; - fputs(str, f); -} - -int isNull(void* ptr) { - return ptr==NULL; -} - -char* getEnvPair(int i) { - return *(environ + i); -} - -void idris_memset(void* ptr, size_t offset, uint8_t c, size_t size) { - memset(((uint8_t*)ptr) + offset, c, size); -} - -uint8_t idris_peek(void* ptr, size_t offset) { - return *(((uint8_t*)ptr) + offset); -} - -void idris_poke(void* ptr, size_t offset, uint8_t data) { - *(((uint8_t*)ptr) + offset) = data; -} - -void idris_memmove(void* dest, void* src, size_t dest_offset, size_t src_offset, size_t size) { - memmove(dest + dest_offset, src + src_offset, size); -} - -void *__idris_gmpMalloc(size_t size) { - return GC_malloc(size); -} - -void *__idris_gmpRealloc(void *ptr, size_t oldSize, size_t size) { - return GC_realloc(ptr, size); -} - -void __idris_gmpFree(void *ptr, size_t oldSize) { - GC_free(ptr); -} - -char *__idris_strRev(const char *s) { - int x = strlen(s); - int y = 0; - char *t = GC_malloc(x+1); - - t[x] = '\0'; - while(x>0) { - t[y++] = s[--x]; - } - return t; -} - -int __idris_argc; -char **__idris_argv; - -int idris_numArgs() { - return __idris_argc; -} - -const char* idris_getArg(int i) { - return __idris_argv[i]; -} diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -42,13 +42,16 @@ runMain (runIdris opts) runIdris :: [Opt] -> Idris () -runIdris [Client c] = do setVerbose False - setQuiet True - runIO $ runClient c runIdris opts = do when (ShowIncs `elem` opts) $ runIO showIncs when (ShowLibs `elem` opts) $ runIO showLibs when (ShowLibdir `elem` opts) $ runIO showLibdir + case opt getClient opts of + [] -> return () + (c:_) -> do setVerbose False + setQuiet True + runIO $ runClient (getPort opts) c + runIO $ exitWith ExitSuccess case opt getPkgCheck opts of [] -> return () fs -> do runIO $ mapM_ (checkPkg (WarnOnly `elem` opts) True) fs diff --git a/rts/arduino/idris_main.c b/rts/arduino/idris_main.c new file mode 100644 --- /dev/null +++ b/rts/arduino/idris_main.c @@ -0,0 +1,29 @@ +#include "idris_opts.h" +#include "idris_stats.h" +#include "idris_rts.h" +#include "Arduino.h" + +// The default options should give satisfactory results under many circumstances. +RTSOpts opts = { + .init_heap_size = 128, + .max_stack_size = 128, + .show_summary = 0 +}; + +// no argv or argc +int main() { + init(); // arduino init function + + VM* vm = init_vm(opts.max_stack_size, opts.init_heap_size, 1); + _idris__123_runMain0_125_(vm, NULL); + +#ifdef IDRIS_DEBUG + if (opts.show_summary) { + idris_gcInfo(vm, 1); + } +#endif + + Stats stats = terminate(vm); + + return 0; +} diff --git a/rts/idris_bitstring.c b/rts/idris_bitstring.c --- a/rts/idris_bitstring.c +++ b/rts/idris_bitstring.c @@ -1,58 +1,66 @@ #include "idris_rts.h" VAL idris_b8CopyForGC(VM *vm, VAL a) { + uint8_t A = a->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 1); SETTY(cl, BITS8); - cl->info.bits8 = a->info.bits8; + cl->info.bits8 = A; return cl; } VAL idris_b16CopyForGC(VM *vm, VAL a) { + uint16_t A = a->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 1); SETTY(cl, BITS16); - cl->info.bits16 = a->info.bits16; + cl->info.bits16 = A; return cl; } VAL idris_b32CopyForGC(VM *vm, VAL a) { + uint32_t A = a->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 1); SETTY(cl, BITS32); - cl->info.bits32 = a->info.bits32; + cl->info.bits32 = A; return cl; } VAL idris_b64CopyForGC(VM *vm, VAL a) { + uint64_t A = a->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 1); SETTY(cl, BITS64); - cl->info.bits64 = a->info.bits64; + cl->info.bits64 = A; return cl; } VAL idris_b8(VM *vm, VAL a) { + uint8_t A = GETINT(a); VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = (uint8_t) GETINT(a); + cl->info.bits8 = (uint8_t) A; return cl; } VAL idris_b16(VM *vm, VAL a) { + uint16_t A = GETINT(a); VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = (uint16_t) GETINT(a); + cl->info.bits16 = (uint16_t) A; return cl; } VAL idris_b32(VM *vm, VAL a) { + uint32_t A = GETINT(a); VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = (uint32_t) GETINT(a); + cl->info.bits32 = (uint32_t) A; return cl; } VAL idris_b64(VM *vm, VAL a) { + uint64_t A = GETINT(a); VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = (uint64_t) GETINT(a); + cl->info.bits64 = (uint64_t) A; return cl; } @@ -89,51 +97,65 @@ } VAL idris_b8Plus(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = a->info.bits8 + b->info.bits8; + cl->info.bits8 = A + B; return cl; } VAL idris_b8Minus(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = a->info.bits8 - b->info.bits8; + cl->info.bits8 = A - B; return cl; } VAL idris_b8Times(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = a->info.bits8 * b->info.bits8; + cl->info.bits8 = A * B; return cl; } VAL idris_b8UDiv(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = a->info.bits8 / b->info.bits8; + cl->info.bits8 = A / B; return cl; } VAL idris_b8SDiv(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = (uint8_t) (((int8_t) a->info.bits8) / ((int8_t) b->info.bits8)); + cl->info.bits8 = (uint8_t) (((int8_t) A) / ((int8_t) B)); return cl; } VAL idris_b8URem(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = a->info.bits8 % b->info.bits8; + cl->info.bits8 = A % B; return cl; } VAL idris_b8SRem(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = (uint8_t) (((int8_t) a->info.bits8) % ((int8_t) b->info.bits8)); + cl->info.bits8 = (uint8_t) (((int8_t) A) % ((int8_t) B)); return cl; } @@ -158,102 +180,127 @@ } VAL idris_b8Compl(VM *vm, VAL a) { + uint8_t A = a->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = ~ a->info.bits8; + cl->info.bits8 = ~ A; return cl; } VAL idris_b8And(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = a->info.bits8 & b->info.bits8; + cl->info.bits8 = A & B; return cl; } VAL idris_b8Or(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = a->info.bits8 | b->info.bits8; + cl->info.bits8 = A | B; return cl; } VAL idris_b8Xor(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = a->info.bits8 ^ b->info.bits8; + cl->info.bits8 = A ^ B; return cl; } VAL idris_b8Shl(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = a->info.bits8 << b->info.bits8; + cl->info.bits8 = A << B; return cl; } VAL idris_b8LShr(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = a->info.bits8 >> b->info.bits8; + cl->info.bits8 = A >> B; return cl; } VAL idris_b8AShr(VM *vm, VAL a, VAL b) { + uint8_t A = a->info.bits8; + uint8_t B = b->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = (uint8_t) (((int8_t)a->info.bits8) >> ((int8_t)b->info.bits8)); + cl->info.bits8 = (uint8_t) (((int8_t) A) >> ((int8_t) B)); return cl; } VAL idris_b16Plus(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = a->info.bits16 + b->info.bits16; + cl->info.bits16 = A + B; return cl; } VAL idris_b16Minus(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = a->info.bits16 - b->info.bits16; + cl->info.bits16 = A - B; return cl; } VAL idris_b16Times(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = a->info.bits16 * b->info.bits16; + cl->info.bits16 = A * B; return cl; } VAL idris_b16UDiv(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = a->info.bits16 / b->info.bits16; + cl->info.bits16 = A / B; return cl; } VAL idris_b16SDiv(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = - (uint16_t) (((int16_t) a->info.bits16) / ((int16_t) b->info.bits16)); + cl->info.bits16 = (uint16_t) (((int16_t) A) / ((int16_t) B)); return cl; } VAL idris_b16URem(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = a->info.bits16 % b->info.bits16; + cl->info.bits16 = A % B; return cl; } VAL idris_b16SRem(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = - (uint16_t) (((int16_t) a->info.bits16) % ((int16_t) b->info.bits16)); + cl->info.bits16 = (uint16_t) (((int16_t) A) % ((int16_t) B)); return cl; } @@ -278,102 +325,127 @@ } VAL idris_b16Compl(VM *vm, VAL a) { + uint16_t A = a->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = ~ a->info.bits16; + cl->info.bits16 = ~ A; return cl; } VAL idris_b16And(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = a->info.bits16 & b->info.bits16; + cl->info.bits16 = A & B; return cl; } VAL idris_b16Or(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = a->info.bits16 | b->info.bits16; + cl->info.bits16 = A | B; return cl; } VAL idris_b16Xor(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = a->info.bits16 ^ b->info.bits16; + cl->info.bits16 = A ^ B; return cl; } VAL idris_b16Shl(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = a->info.bits16 << b->info.bits16; + cl->info.bits16 = A << B; return cl; } VAL idris_b16LShr(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = a->info.bits16 >> b->info.bits16; + cl->info.bits16 = A >> B; return cl; } VAL idris_b16AShr(VM *vm, VAL a, VAL b) { + uint16_t A = a->info.bits16; + uint16_t B = b->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = (uint16_t) (((int16_t)a->info.bits16) >> ((int16_t)b->info.bits16)); + cl->info.bits16 = (uint16_t) (((int16_t) A) >> ((int16_t) B)); return cl; } VAL idris_b32Plus(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = a->info.bits32 + b->info.bits32; + cl->info.bits32 = A + B; return cl; } VAL idris_b32Minus(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = a->info.bits32 - b->info.bits32; + cl->info.bits32 = A - B; return cl; } VAL idris_b32Times(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = a->info.bits32 * b->info.bits32; + cl->info.bits32 = A * B; return cl; } VAL idris_b32UDiv(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = a->info.bits32 / b->info.bits32; + cl->info.bits32 = A / B; return cl; } VAL idris_b32SDiv(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = - (uint32_t) (((int32_t) a->info.bits32) / ((int32_t) b->info.bits32)); + cl->info.bits32 = (uint32_t) (((int32_t) A) / ((int32_t) B)); return cl; } VAL idris_b32URem(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = a->info.bits32 % b->info.bits32; + cl->info.bits32 = A % B; return cl; } VAL idris_b32SRem(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = - (uint32_t) (((int32_t) a->info.bits32) % ((int32_t) b->info.bits32)); + cl->info.bits32 = (uint32_t) (((int32_t) A) % ((int32_t) B)); return cl; } @@ -398,102 +470,127 @@ } VAL idris_b32Compl(VM *vm, VAL a) { + uint32_t A = a->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = ~ a->info.bits32; + cl->info.bits32 = ~ A; return cl; } VAL idris_b32And(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = a->info.bits32 & b->info.bits32; + cl->info.bits32 = A & B; return cl; } VAL idris_b32Or(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = a->info.bits32 | b->info.bits32; + cl->info.bits32 = A | B; return cl; } VAL idris_b32Xor(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = a->info.bits32 ^ b->info.bits32; + cl->info.bits32 = A ^ B; return cl; } VAL idris_b32Shl(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = a->info.bits32 << b->info.bits32; + cl->info.bits32 = A << B; return cl; } VAL idris_b32LShr(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = a->info.bits32 >> b->info.bits32; + cl->info.bits32 = A >> B; return cl; } VAL idris_b32AShr(VM *vm, VAL a, VAL b) { + uint32_t A = a->info.bits32; + uint32_t B = b->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = (uint32_t) (((int32_t)a->info.bits32) >> ((int32_t)b->info.bits32)); + cl->info.bits32 = (uint32_t) (((int32_t)A) >> ((int32_t)B)); return cl; } VAL idris_b64Plus(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = a->info.bits64 + b->info.bits64; + cl->info.bits64 = A + B; return cl; } VAL idris_b64Minus(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = a->info.bits64 - b->info.bits64; + cl->info.bits64 = A - B; return cl; } VAL idris_b64Times(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = a->info.bits64 * b->info.bits64; + cl->info.bits64 = A * B; return cl; } VAL idris_b64UDiv(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = a->info.bits64 / b->info.bits64; + cl->info.bits64 = A / B; return cl; } VAL idris_b64SDiv(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = - (uint64_t) (((int64_t) a->info.bits64) / ((int64_t) b->info.bits64)); + cl->info.bits64 = (uint64_t) (((int64_t) A) / ((int64_t) B)); return cl; } VAL idris_b64URem(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = a->info.bits64 % b->info.bits64; + cl->info.bits64 = A % B; return cl; } VAL idris_b64SRem(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = - (uint64_t) (((int64_t) a->info.bits64) % ((int64_t) b->info.bits64)); + cl->info.bits64 = (uint64_t) (((int64_t) A) % ((int64_t) B)); return cl; } @@ -518,177 +615,208 @@ } VAL idris_b64Compl(VM *vm, VAL a) { + uint64_t A = a->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = ~ a->info.bits64; + cl->info.bits64 = ~ A; return cl; } VAL idris_b64And(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = a->info.bits64 & b->info.bits64; + cl->info.bits64 = A & B; return cl; } VAL idris_b64Or(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = a->info.bits64 | b->info.bits64; + cl->info.bits64 = A | B; return cl; } VAL idris_b64Xor(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = a->info.bits64 ^ b->info.bits64; + cl->info.bits64 = A ^ B; return cl; } VAL idris_b64Shl(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = a->info.bits64 << b->info.bits64; + cl->info.bits64 = A << B; return cl; } VAL idris_b64LShr(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = a->info.bits64 >> b->info.bits64; + cl->info.bits64 = A >> B; return cl; } VAL idris_b64AShr(VM *vm, VAL a, VAL b) { + uint64_t A = a->info.bits64; + uint64_t B = b->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = (uint64_t) (((int64_t)a->info.bits64) >> ((int64_t)b->info.bits64)); + cl->info.bits64 = (uint64_t) (((int64_t) A) >> ((int64_t) B)); return cl; } VAL idris_b8Z16(VM *vm, VAL a) { + uint8_t A = a->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = (uint16_t) a->info.bits8; + cl->info.bits16 = (uint16_t) A; return cl; } VAL idris_b8Z32(VM *vm, VAL a) { + uint8_t A = a->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = (uint32_t) a->info.bits8; + cl->info.bits32 = (uint32_t) A; return cl; } VAL idris_b8Z64(VM *vm, VAL a) { + uint8_t A = a->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); - SETTY(cl, BITS16); - cl->info.bits64 = (uint64_t) a->info.bits8; + SETTY(cl, BITS64); + cl->info.bits64 = (uint64_t) A; return cl; } VAL idris_b8S16(VM *vm, VAL a) { + uint8_t A = a->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = (uint16_t) (int16_t) (int8_t) a->info.bits8; + cl->info.bits16 = (uint16_t) (int16_t) (int8_t) A; return cl; } VAL idris_b8S32(VM *vm, VAL a) { + uint8_t A = a->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = (uint32_t) (int32_t) (int8_t) a->info.bits8; + cl->info.bits32 = (uint32_t) (int32_t) (int8_t) A; return cl; } VAL idris_b8S64(VM *vm, VAL a) { + uint8_t A = a->info.bits8; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = (uint64_t) (int64_t) (int8_t) a->info.bits8; + cl->info.bits64 = (uint64_t) (int64_t) (int8_t) A; return cl; } VAL idris_b16Z32(VM *vm, VAL a) { + uint16_t A = a->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = (uint32_t) a->info.bits16; + cl->info.bits32 = (uint32_t) A; return cl; } VAL idris_b16Z64(VM *vm, VAL a) { + uint16_t A = a->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = (uint64_t) a->info.bits16; + cl->info.bits64 = (uint64_t) A; return cl; } VAL idris_b16S32(VM *vm, VAL a) { + uint16_t A = a->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = (uint32_t) (int32_t) (int16_t) a->info.bits16; + cl->info.bits32 = (uint32_t) (int32_t) (int16_t) A; return cl; } VAL idris_b16S64(VM *vm, VAL a) { + uint16_t A = a->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = (uint64_t) (int64_t) (int16_t) a->info.bits16; + cl->info.bits64 = (uint64_t) (int64_t) (int16_t) A; return cl; } VAL idris_b16T8(VM *vm, VAL a) { + uint16_t A = a->info.bits16; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = (uint8_t) a->info.bits16; + cl->info.bits8 = (uint8_t) A; return cl; } VAL idris_b32Z64(VM *vm, VAL a) { + uint32_t A = a->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = (uint64_t) a->info.bits32; + cl->info.bits64 = (uint64_t) A; return cl; } VAL idris_b32S64(VM *vm, VAL a) { + uint32_t A = a->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS64); - cl->info.bits64 = (uint64_t) (int64_t) (int32_t) a->info.bits32; + cl->info.bits64 = (uint64_t) (int64_t) (int32_t) A; return cl; } VAL idris_b32T8(VM *vm, VAL a) { + uint32_t A = a->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = (uint8_t) a->info.bits32; + cl->info.bits8 = (uint8_t) A; return cl; } VAL idris_b32T16(VM *vm, VAL a) { + uint32_t A = a->info.bits32; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = (uint16_t) a->info.bits32; + cl->info.bits16 = (uint16_t) A; return cl; } VAL idris_b64T8(VM *vm, VAL a) { + uint64_t A = a->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8); - cl->info.bits8 = (uint8_t) a->info.bits64; + cl->info.bits8 = (uint8_t) A; return cl; } VAL idris_b64T16(VM *vm, VAL a) { + uint64_t A = a->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS16); - cl->info.bits16 = (uint16_t) a->info.bits64; + cl->info.bits16 = (uint16_t) A; return cl; } VAL idris_b64T32(VM *vm, VAL a) { + uint64_t A = a->info.bits64; VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS32); - cl->info.bits32 = (uint32_t) a->info.bits64; + cl->info.bits32 = (uint32_t) A; return cl; } diff --git a/rts/idris_gc.c b/rts/idris_gc.c --- a/rts/idris_gc.c +++ b/rts/idris_gc.c @@ -151,7 +151,9 @@ printf("Final heap use %d\n", (int)(vm->heap.next - vm->heap.heap)); if (doGC) { idris_gc(vm); } printf("Final heap use after GC %d\n", (int)(vm->heap.next - vm->heap.heap)); - +#ifdef IDRIS_ENABLE_STATS printf("Total allocations %d\n", vm->stats.allocations); +#endif printf("Number of collections %d\n", vm->stats.collections); + } diff --git a/rts/idris_rts.c b/rts/idris_rts.c --- a/rts/idris_rts.c +++ b/rts/idris_rts.c @@ -346,10 +346,11 @@ } VAL idris_castIntStr(VM* vm, VAL i) { + int x = (int) GETINT(i); Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*16, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); - sprintf(cl -> info.str, "%d", (int)(GETINT(i))); + sprintf(cl -> info.str, "%d", x); return cl; } diff --git a/rts/idris_rts.h b/rts/idris_rts.h --- a/rts/idris_rts.h +++ b/rts/idris_rts.h @@ -13,6 +13,13 @@ #include "idris_heap.h" #include "idris_stats.h" +#ifndef EXIT_SUCCESS +#define EXIT_SUCCESS 0 +#endif +#ifndef EXIT_FAILURE +#define EXIT_FAILURE 1 +#endif + // Closures typedef enum { diff --git a/rts/idris_stats.h b/rts/idris_stats.h --- a/rts/idris_stats.h +++ b/rts/idris_stats.h @@ -1,10 +1,10 @@ #ifndef _IDRIS_STATS_H #define _IDRIS_STATS_H +#ifdef IDRIS_ENABLE_STATS #include +#endif -// Should not be defined in release. -#define IDRIS_ENABLE_STATS // TODO: measure user time, exclusive/inclusive stats typedef struct { diff --git a/src/IRTS/CodegenC.hs b/src/IRTS/CodegenC.hs --- a/src/IRTS/CodegenC.hs +++ b/src/IRTS/CodegenC.hs @@ -67,7 +67,8 @@ let gcc = comp ++ " " ++ gccDbg dbg ++ " " ++ gccFlags ++ - " -DHAS_PTHREAD " ++ + -- # Any flags defined here which alter the RTS API must also be added to config.mk + " -DHAS_PTHREAD -DIDRIS_ENABLE_STATS" ++ " -I. " ++ objs ++ " -x c " ++ (if (exec == Executable) then "" else " -c ") ++ " " ++ tmpn ++ @@ -437,7 +438,7 @@ doOp v (LSExt (ITFixed from) (ITFixed to)) [x] | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x doOp v (LZExt ITNative (ITFixed to)) [x] - = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")" + = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ "))" doOp v (LZExt ITChar (ITFixed to)) [x] = doOp v (LZExt ITNative (ITFixed to)) [x] doOp v (LZExt (ITFixed from) ITNative) [x] @@ -474,6 +475,7 @@ doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x) doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x) doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x) +doOp v LFNegate [x] = v ++ "MKFLOAT(vm, -GETFLOAT(" ++ (creg x) ++ "))" doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")" doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")" diff --git a/src/IRTS/CodegenCommon.hs b/src/IRTS/CodegenCommon.hs --- a/src/IRTS/CodegenCommon.hs +++ b/src/IRTS/CodegenCommon.hs @@ -25,7 +25,6 @@ outputType :: OutputType, targetTriple :: String, targetCPU :: String, - optimisation :: Word, includes :: [FilePath], importDirs :: [FilePath], compileObjs :: [String], diff --git a/src/IRTS/CodegenJava.hs b/src/IRTS/CodegenJava.hs deleted file mode 100644 --- a/src/IRTS/CodegenJava.hs +++ /dev/null @@ -1,757 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -module IRTS.CodegenJava (codegenJava) where - -import Idris.Core.TT hiding (mkApp) -import IRTS.CodegenCommon -import IRTS.Java.ASTBuilding -import IRTS.Java.JTypes -import IRTS.Java.Mangling -import IRTS.Java.Pom (pomString) -import IRTS.Lang -import IRTS.Simplified -import IRTS.System -import Util.System - -import Control.Applicative hiding (Const) -import Control.Arrow -import Control.Monad -import Control.Monad.Error -import qualified Control.Monad.Trans as T -import Control.Monad.Trans.State -import Data.List (foldl', isSuffixOf) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import qualified Data.Vector.Unboxed as V -import Language.Java.Parser -import Language.Java.Pretty -import Language.Java.Syntax hiding (Name) -import qualified Language.Java.Syntax as J -import System.Directory -import System.Exit -import System.FilePath -import System.IO -import System.Process - ------------------------------------------------------------------------ --- Main function -codegenJava :: CodeGenerator -codegenJava cg = codegenJava' [] (simpleDecls cg) (outputFile cg) - (includes cg) (compileLibs cg) - (outputType cg) - -codegenJava' :: [(Name, SExp)] -> -- initialization of globals - [(Name, SDecl)] -> -- decls - FilePath -> -- output file name - [String] -> -- headers - [String] -> -- libs - OutputType -> - IO () -codegenJava' globalInit defs out hdrs libs exec = - withTgtDir exec out (codegenJava' exec) - where - codegenJava' :: OutputType -> FilePath -> IO () - codegenJava' Raw tgtDir = do - srcDir <- prepareSrcDir exec tgtDir - generateJavaFile globalInit defs hdrs srcDir out - codegenJava' MavenProject tgtDir = do - codegenJava' Raw tgtDir - generatePom tgtDir out libs - codegenJava' Object tgtDir = do - codegenJava' MavenProject tgtDir - invokeMvn tgtDir "compile" - copyClassFiles tgtDir out - cleanUpTmp tgtDir - codegenJava' _ tgtDir = do - codegenJava' MavenProject tgtDir - invokeMvn tgtDir "package"; - copyJar tgtDir out - makeJarExecutable out - cleanUpTmp tgtDir - ------------------------------------------------------------------------ --- Compiler IO - -withTgtDir :: OutputType -> FilePath -> (FilePath -> IO ()) -> IO () -withTgtDir Raw out action = action (dropFileName out) -withTgtDir MavenProject out action = createDirectoryIfMissing False out >> action out -withTgtDir _ out action = withTempdir (takeBaseName out) action - -prepareSrcDir :: OutputType -> FilePath -> IO FilePath -prepareSrcDir Raw tgtDir = return tgtDir -prepareSrcDir _ tgtDir = do - let srcDir = (tgtDir "src" "main" "java") - createDirectoryIfMissing True srcDir - return srcDir - -javaFileName :: FilePath -> FilePath -> FilePath -javaFileName srcDir out = - either error (\ (Ident clsName) -> srcDir clsName <.> "java") (mkClassName out) - -generateJavaFile :: [(Name, SExp)] -> -- initialization of globals - [(Name, SDecl)] -> -- definitions - [String] -> -- headers - FilePath -> -- Source dir - FilePath -> -- output target - IO () -generateJavaFile globalInit defs hdrs srcDir out = do - let code = either error - (prettyPrint)-- flatIndent . prettyPrint) - (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv) - writeFile (javaFileName srcDir out) code - -pomFileName :: FilePath -> FilePath -pomFileName tgtDir = tgtDir "pom.xml" - -generatePom :: FilePath -> -- tgt dir - FilePath -> -- output target - [String] -> -- libs - IO () -generatePom tgtDir out libs = writeFile (pomFileName tgtDir) execPom - where - (Ident clsName) = either error id (mkClassName out) - execPom = pomString clsName (takeBaseName out) libs - - -invokeMvn :: FilePath -> String -> IO () -invokeMvn tgtDir command = do - mvnCmd <- getMvn - let args = ["-f", pomFileName tgtDir] - (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ [command]) "" - when (exit /= ExitSuccess) $ - error ("FAILURE: " ++ mvnCmd ++ " " ++ command ++ "\n" ++ err ++ mvout) - -classFileDir :: FilePath -> FilePath -classFileDir tgtDir = tgtDir "target" "classes" - -copyClassFiles :: FilePath -> FilePath -> IO () -copyClassFiles tgtDir out = do - classFiles <- map (\ clsFile -> classFileDir tgtDir clsFile) - . filter ((".class" ==) . takeExtension) - <$> getDirectoryContents (classFileDir tgtDir) - mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out takeFileName clsFile)) classFiles - -jarFileName :: FilePath -> FilePath -> FilePath -jarFileName tgtDir out = tgtDir "target" (takeBaseName out) <.> "jar" - -copyJar :: FilePath -> FilePath -> IO () -copyJar tgtDir out = - copyFile (jarFileName tgtDir out) out - -makeJarExecutable :: FilePath -> IO () -makeJarExecutable out = do - handle <- openBinaryFile out ReadMode - contents <- TIO.hGetContents handle - hClose handle - handle <- openBinaryFile out WriteMode - TIO.hPutStr handle (T.append (T.pack jarHeader) contents) - hFlush handle - hClose handle - perms <- getPermissions out - setPermissions out (setOwnerExecutable True perms) - -removePom :: FilePath -> IO () -removePom tgtDir = removeFile (pomFileName tgtDir) - -cleanUpTmp :: FilePath -> IO () -cleanUpTmp tgtDir = do - invokeMvn tgtDir "clean" - removePom tgtDir - ------------------------------------------------------------------------ --- Jar and Pom infrastructure - -jarHeader :: String -jarHeader = - "#!/usr/bin/env sh\n" - ++ "MYSELF=`which \"$0\" 2>/dev/null`\n" - ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n" - ++ "java=java\n" - ++ "if test -n \"$JAVA_HOME\"; then\n" - ++ " java=\"$JAVA_HOME/bin/java\"\n" - ++ "fi\n" - ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\"\n" - ++ "exit 1\n" - ------------------------------------------------------------------------ --- Code generation environment - -data CodeGenerationEnv - = CodeGenerationEnv - { globalVariables :: [(Name, ArrayIndex)] - , localVariables :: [[(Int, Ident)]] - , localVarCounter :: Int - } - -type CodeGeneration = StateT (CodeGenerationEnv) (Either String) - -mkCodeGenEnv :: CodeGenerationEnv -mkCodeGenEnv = CodeGenerationEnv [] [] 0 - -varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident) -varPos (Loc i) = do - vars <- (concat . localVariables) <$> get - case lookup i vars of - (Just varName) -> return (Right varName) - Nothing -> throwError $ "Invalid local variable id: " ++ show i -varPos (Glob name) = do - vars <- globalVariables <$> get - case lookup name vars of - (Just varIdx) -> return (Left varIdx) - Nothing -> throwError $ "Invalid global variable id: " ++ show name - -pushScope :: CodeGeneration () -pushScope = - modify (\ env -> env { localVariables = []:(localVariables env) }) - -popScope :: CodeGeneration () -popScope = do - env <- get - let lVars = tail $ localVariables env - let vC = if null lVars then 0 else localVarCounter env - put $ env { localVariables = tail (localVariables env) - , localVarCounter = vC } - -setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident) -setVariable (Loc i) = do - env <- get - let lVars = localVariables env - let getter = localVar $ localVarCounter env - let lVars' = ((i, getter) : head lVars) : tail lVars - put $ env { localVariables = lVars' - , localVarCounter = 1 + localVarCounter env} - return (Right getter) -setVariable (Glob n) = do - env <- get - let gVars = globalVariables env - let getter = globalContext @! length gVars - let gVars' = (n, getter):gVars - put (env { globalVariables = gVars' }) - return (Left getter) - -pushParams :: [Ident] -> CodeGeneration () -pushParams paramNames = - let varMap = zipWith (flip (,)) paramNames [0..] in - modify (\ env -> env { localVariables = varMap:(localVariables env) - , localVarCounter = (length varMap) + (localVarCounter env) }) - -flatIndent :: String -> String -flatIndent (' ' : ' ' : xs) = flatIndent xs -flatIndent (x:xs) = x:flatIndent xs -flatIndent [] = [] - ------------------------------------------------------------------------ --- Maintaining control structures over code blocks - -data BlockPostprocessor - = BlockPostprocessor - { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt] - , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt] - } - -ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt] -ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp - -addReturn :: BlockPostprocessor -addReturn = - BlockPostprocessor - { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp]) - , ppOuterBlock = return - } - -ignoreResult :: BlockPostprocessor -ignoreResult = - BlockPostprocessor - { ppInnerBlock = (\ block exp -> return block) - , ppOuterBlock = return - } - -ignoreOuter :: BlockPostprocessor -> BlockPostprocessor -ignoreOuter pp = pp { ppOuterBlock = return } - -throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor -throwRuntimeException pp = - pp - { ppInnerBlock = - (\ blk exp -> return $ - blk ++ [ BlockStmt $ Throw - ( InstanceCreation - [] - (toClassType runtimeExceptionType) - [exp] - Nothing - ) - ] - ) - } - - -rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor -rethrowAsRuntimeException pp = - pp - { ppOuterBlock = - (\ blk -> do - ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"]) - ppOuterBlock pp - $ [ BlockStmt $ Try - (Block blk) - [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $ - Block ex - ] - Nothing - ] - ) - } - ------------------------------------------------------------------------ --- File structure - -mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit -mkCompilationUnit globalInit defs hdrs out = do - clsName <- mkClassName out - CompilationUnit Nothing ( [ ImportDecl False idrisRts True - , ImportDecl True idrisPrelude True - , ImportDecl False bigInteger False - , ImportDecl False runtimeException False - , ImportDecl False byteBuffer False - ] ++ otherHdrs - ) - <$> mkTypeDecl clsName globalInit defs - where - idrisRts = J.Name $ map Ident ["org", "idris", "rts"] - idrisPrelude = J.Name $ map Ident ["org", "idris", "rts", "Prelude"] - bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"] - runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"] - byteBuffer = J.Name $ map Ident ["java", "nio", "ByteBuffer"] - otherHdrs = map ( (\ name -> ImportDecl False name False) - . J.Name - . map (Ident . T.unpack) - . T.splitOn (T.pack ".") - . T.pack) - $ filter (not . isSuffixOf ".h") hdrs - ------------------------------------------------------------------------ --- Main class - -mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl] -mkTypeDecl name globalInit defs = - (\ body -> [ClassTypeDecl $ ClassDecl [ Public - , Annotation $ SingleElementAnnotation - (jName "SuppressWarnings") - (EVVal . InitExp $ jString "unchecked") - ] - name - [] - Nothing - [] - body]) - <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs) - -mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody -mkClassBody globalInit defs = - (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs) - <$> mkGlobalContext globalInit - <*> mapM mkDecl defs - -mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl] -mkGlobalContext [] = return [] -mkGlobalContext initExps = do - pushScope - varInit <- - mapM (\ (name, exp) -> do - pos <- setVariable (Glob name) - mkUpdate ignoreResult (Glob name) exp - ) initExps - popScope - return [ MemberDecl $ FieldDecl [Private, Static, Final] - (array objectType) - [ VarDecl (VarId $ globalContextID). Just . InitExp - $ ArrayCreate objectType [jInt $ length initExps] 0 - ] - , InitDecl True (Block $ concat varInit) - ] - -addMainMethod :: [Decl] -> [Decl] -addMainMethod decls - | findMainMethod decls = mkMainMethod : decls - | otherwise = decls - where - findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_) - | name == mangle' (sMN 0 "runMain") = True - findMainMethod (_:decls) = findMainMethod decls - findMainMethod [] = False - -mkMainMethod :: Decl -mkMainMethod = - simpleMethod - [Public, Static] - Nothing - "main" - [FormalParam [] (array stringType) False (VarId $ Ident "args")] - $ Block [ BlockStmt . ExpStmt - $ call "idris_initArgs" [ jConst "args" ] - , BlockStmt . ExpStmt $ call (mangle' (sMN 0 "runMain")) [] - ] - ------------------------------------------------------------------------ --- Inner classes (idris namespaces) - -mergeInnerClasses :: [Decl] -> [Decl] -mergeInnerClasses = foldl' mergeInner [] - where - mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls) - decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body')))) - | name == name' = - (MemberDecl $ MemberClassDecl $ - ClassDecl priv - name - targs - (mplus ext ext') - (imp ++ imp') - (ClassBody $ mergeInnerClasses (body ++ body'))) - : decls - | otherwise = decl:(mergeInner decls decl') - mergeInner (decl:decls) decl' = decl:(mergeInner decls decl') - mergeInner [] decl' = [decl'] - - - -mkDecl :: (Name, SDecl) -> CodeGeneration Decl -mkDecl ((NS n (ns:nss)), decl) = - (\ name body -> - MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body) - <$> mangle (UN ns) - <*> mkClassBody [] [(NS n nss, decl)] -mkDecl (_, SFun name params stackSize body) = do - (Ident methodName) <- mangle name - methodParams <- mapM mkFormalParam params - paramNames <- mapM mangle params - pushParams paramNames - methodBody <- mkExp addReturn body - popScope - return $ - simpleMethod [Public, Static] (Just objectType) methodName methodParams - (Block methodBody) - -mkFormalParam :: Name -> CodeGeneration FormalParam -mkFormalParam name = - (\ name -> FormalParam [Final] objectType False (VarId name)) - <$> mangle name - ------------------------------------------------------------------------ --- Expressions - --- | Compile a simple expression and use the given continuation to postprocess --- the resulting value. -mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt] --- Variables -mkExp pp (SV var) = - (Nothing <>@! var) >>= ppExp pp - --- Applications -mkExp pp (SApp pushTail name args) = - mkApp pushTail name args >>= ppExp pp - --- Bindings -mkExp pp (SLet var newExp inExp) = - mkLet pp var newExp inExp -mkExp pp (SUpdate var@(Loc i) newExp) = -- can only update locals - mkUpdate pp var newExp -mkExp pp (SUpdate var newExp) = - mkExp pp newExp - --- Objects -mkExp pp (SCon _ conId _ args) = - mkIdrisObject conId args >>= ppExp pp - --- Case expressions -mkExp pp (SCase up var alts) = mkCase pp True var alts -mkExp pp (SChkCase var alts) = mkCase pp False var alts - --- Projections -mkExp pp (SProj var i) = - mkProjection var i >>= ppExp pp - --- Constants -mkExp pp (SConst c) = - ppExp pp $ mkConstant c - --- Foreign function calls -mkExp pp (SForeign lang resTy text params) = - mkForeign pp lang resTy text params - --- Primitive functions -mkExp pp (SOp LFork [arg]) = - (mkThread arg) >>= ppExp pp -mkExp pp (SOp LPar [arg]) = - (Nothing <>@! arg) >>= ppExp pp -mkExp pp (SOp LRegisterPtr [ptr, i]) = - (Nothing <>@! ptr) >>= ppExp pp -mkExp pp (SOp LNoOp args) = - (Nothing <>@! (last args)) >>= ppExp pp -mkExp pp (SOp LNullPtr args) = - ppExp pp $ Lit Null -mkExp pp (SOp op args) = - (mkPrimitiveFunction op args) >>= ppExp pp - --- Empty expressions -mkExp pp (SNothing) = ppExp pp $ Lit Null - --- Errors -mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err) - ------------------------------------------------------------------------ --- Variable access - -(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp -(<>@!) Nothing var = - either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var -(<>@!) (Just castTo) var = - (castTo <>) <$> (Nothing <>@! var) - ------------------------------------------------------------------------ --- Application (wrap method calls in tail call closures) - -mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp -mkApp False name args = - (\ methodName params -> - (idrisClosureType ~> "unwrapTailCall") [call methodName params] - ) - <$> mangleFull name - <*> mapM (Nothing <>@!) args -mkApp True name args = mkMethodCallClosure name args - -mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp -mkMethodCallClosure name args = - (\ name args -> closure (call name args)) - <$> mangleFull name - <*> mapM (Nothing <>@!) args - ------------------------------------------------------------------------ --- Updates (change context array) and Let bindings (Update, execute) - -mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt] -mkUpdate pp var exp = - mkExp - ( pp - { ppInnerBlock = - (\ blk rhs -> do - pos <- setVariable var - vExp <- Nothing <>@! var - ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp - ) - } - ) exp - -mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt] -mkLet pp var@(Loc pos) newExp inExp = - mkUpdate (pp { ppInnerBlock = - (\ blk _ -> do - inBlk <- mkExp pp inExp - return (blk ++ inBlk) - ) - } - ) var newExp -mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable" - ------------------------------------------------------------------------ --- Object creation - -mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp -mkIdrisObject conId args = - (\ args -> - InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing - ) - <$> mapM (Nothing <>@!) args - ------------------------------------------------------------------------ --- Case expressions - -mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt] -mkCase pp checked var cases - | isDefaultOnlyCase cases = mkDefaultMatch pp cases - | isConstCase cases = do - ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases - ppOuterBlock pp [BlockStmt ifte] - | otherwise = do - switchExp <- mkGetConstructorId checked var - matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases - ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks] - -isConstCase :: [SAlt] -> Bool -isConstCase ((SConstCase _ _):_) = True -isConstCase ((SDefaultCase _):cases) = isConstCase cases -isConstCase _ = False - -isDefaultOnlyCase :: [SAlt] -> Bool -isDefaultOnlyCase [SDefaultCase _] = True -isDefaultOnlyCase [] = True -isDefaultOnlyCase _ = False - -mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt] -mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) = - do pushScope - stmt <- mkExp pp branchExpression - popScope - return stmt -mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs -mkDefaultMatch pp [] = - ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern") - -mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp -mkMatchConstExp var c - | isPrimitive cty = - (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1) - <$> (Just cty <>@! var) - | isArray cty = - (\ var -> (arraysType ~> "equals") [var, jc]) - <$> (Just cty <>@! var) - | isString cty = - (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1)) - <$> (Just cty <>@! var) - | otherwise = - (\ var -> (var ~> "equals") [jc]) - <$> (Just cty <>@! var) - where - cty = constType c - jc = mkConstant c - -mkConstMatch :: BlockPostprocessor -> - (BlockPostprocessor -> CodeGeneration [BlockStmt]) -> - LVar -> - [SAlt] -> - CodeGeneration Stmt -mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do - matchExp <- mkMatchConstExp var constant - pushScope - branchBlock <- mkExp pp branchExpression - popScope - otherBranches <- mkConstMatch pp getDefaultStmts var cases - return - $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches -mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases -mkConstMatch pp getDefaultStmts _ [] = do - defaultBlock <- getDefaultStmts pp - return $ StmtBlock (Block defaultBlock) - -mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp -mkGetConstructorId True var = - (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") []) - <$> (Nothing <>@! var) -mkGetConstructorId False var = - (\ var match -> - Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1)) - ) - <$> (Nothing <>@! var) - <*> mkGetConstructorId True var - -mkConsMatch :: BlockPostprocessor -> - (BlockPostprocessor -> CodeGeneration [BlockStmt]) -> - LVar -> - [SAlt] -> - CodeGeneration [SwitchBlock] -mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do - pushScope - caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression - popScope - otherBranches <- mkConsMatch pp getDefaultStmts var cases - return $ - (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches -mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases -mkConsMatch pp getDefaultStmts _ [] = do - defaultBlock <- getDefaultStmts pp - return $ - [SwitchBlock Default defaultBlock] - -mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt] -mkCaseBinding pp var stackStart params branchExpression = - mkExp pp (toLetIn var stackStart params branchExpression) - where - toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp - toLetIn var stackStart members start = - foldr - (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp) - start - [0.. (length members - 1)] - ------------------------------------------------------------------------ --- Projection (retrieve the n-th field of an object) - -mkProjection :: LVar -> Int -> CodeGeneration Exp -mkProjection var memberNr = - (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr) - <$> (Just idrisObjectType <>@! var) - ------------------------------------------------------------------------ --- Constants - -mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp -mkConstantArray cty elemToConst elems = - ArrayCreateInit - cty - 0 - (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems) - -mkConstant :: Const -> Exp -mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x) -mkConstant c@(BI x) = bigInteger (show x) -mkConstant c@(Fl x) = constType c <> (Lit . Double $ x) -mkConstant c@(Ch x) = constType c <> (Lit . Char $ x) -mkConstant c@(Str x) = constType c <> (Lit . String $ x) -mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x) -mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x) -mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x) -mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") [] -mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x -mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x -mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x -mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x -mkConstant c@(AType x) = ClassLit (Just $ box (constType c)) -mkConstant c@(StrType ) = ClassLit (Just $ stringType) -mkConstant c@(PtrType ) = ClassLit (Just $ objectType) -mkConstant c@(ManagedPtrType) = ClassLit (Just $ objectType) -mkConstant c@(BufferType) = ClassLit (Just $ bufferType) -mkConstant c@(VoidType ) = ClassLit (Just $ voidType) -mkConstant c@(Forgot ) = ClassLit (Just $ objectType) - ------------------------------------------------------------------------ --- Foreign function calls - -mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt] -mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params -mkForeign pp (LANG_JAVA callType) resTy text params - | callType <- FStatic = do - method <- liftParsed (parser name text) - args <- foreignVarAccess params - wrapReturn resTy (call method args) - | callType <- FObject = do - method <- liftParsed (parser ident text) - (tgt:args) <- foreignVarAccess params - wrapReturn resTy ((tgt ~> (show $ pretty method)) args) - | callType <- FConstructor = do - clsTy <- liftParsed (parser classType text) - args <- foreignVarAccess params - wrapReturn resTy (InstanceCreation [] clsTy args Nothing) - where - foreignVarAccess args = - mapM (\ (fty, var) -> (foreignType fty <>@! var)) args - - pp' = rethrowAsRuntimeException pp - - wrapReturn FUnit exp = - ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp' - wrapReturn _ exp = - ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp' - ------------------------------------------------------------------------ --- Primitive functions - -mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp -mkPrimitiveFunction op args = - (\ args -> (primFnType ~> opName op) (endiannessArguments op ++ args)) - <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op)) - -mkThread :: LVar -> CodeGeneration Exp -mkThread arg = - (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (sMN 0 "EVAL") [arg] - - diff --git a/src/IRTS/CodegenJavaScript.hs b/src/IRTS/CodegenJavaScript.hs --- a/src/IRTS/CodegenJavaScript.hs +++ b/src/IRTS/CodegenJavaScript.hs @@ -1213,6 +1213,8 @@ , (arg:_) <- args = jsCall "parseFloat" [translateReg arg] | (LIntFloat ITNative) <- op , (arg:_) <- args = translateReg arg + | (LIntFloat ITBig) <- op + , (arg:_) <- args = jsMeth (translateReg arg) "intValue" [] | (LFloatInt ITNative) <- op , (arg:_) <- args = translateReg arg | (LChInt ITNative) <- op @@ -1242,6 +1244,8 @@ , (arg:_) <- args = jsCall "Math.floor" [translateReg arg] | LFCeil <- op , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg] + | LFNegate <- op + , (arg:_) <- args = JSPreOp "-" (translateReg arg) | LStrCons <- op , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs] diff --git a/src/IRTS/CodegenLLVM.hs b/src/IRTS/CodegenLLVM.hs deleted file mode 100644 --- a/src/IRTS/CodegenLLVM.hs +++ /dev/null @@ -1,1320 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module IRTS.CodegenLLVM (codegenLLVM) where - -import IRTS.CodegenCommon -import IRTS.Lang -import IRTS.Simplified -import IRTS.System -import qualified Idris.Core.TT as TT -import Idris.Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth) - -import Util.System - -import LLVM.General.Context -import LLVM.General.Diagnostic -import LLVM.General.AST -import LLVM.General.AST.AddrSpace -import LLVM.General.Target ( TargetMachine - , withTargetOptions, withTargetMachine, getTargetMachineDataLayout - , initializeAllTargets, lookupTarget - ) -import LLVM.General.AST.DataLayout -import qualified LLVM.General.PassManager as PM -import qualified LLVM.General.Module as MO -import qualified LLVM.General.AST.IntegerPredicate as IPred -import qualified LLVM.General.AST.FloatingPointPredicate as FPred -import qualified LLVM.General.AST.Linkage as L -import qualified LLVM.General.AST.Visibility as V -import qualified LLVM.General.AST.CallingConvention as CC -import qualified LLVM.General.AST.Attribute as A -import qualified LLVM.General.AST.Global as G -import qualified LLVM.General.AST.Constant as C -import qualified LLVM.General.AST.Float as F -import qualified LLVM.General.Relocation as R -import qualified LLVM.General.CodeModel as CM -import qualified LLVM.General.CodeGenOpt as CGO - -import Data.List -import Data.Maybe -import Data.Word -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 -import Control.Monad.Writer -import Control.Monad.State -import Control.Monad.Error - -import qualified System.Info as SI (arch, os) -import System.IO -import System.Directory (removeFile) -import System.FilePath (()) -import System.Process (rawSystem) -import System.Exit (ExitCode(..)) -import Debug.Trace - -data Target = Target { triple :: String, dataLayout :: DataLayout } - -codegenLLVM :: CodeGenerator -codegenLLVM ci = codegenLLVM' (simpleDecls ci) (targetTriple ci) - (targetCPU ci) (optimisation ci) - (outputFile ci) (outputType ci) - -codegenLLVM' :: [(TT.Name, SDecl)] -> - String -> -- target triple - String -> -- target CPU - Word -> -- Optimization degree - FilePath -> -- output file name - OutputType -> - IO () -codegenLLVM' defs triple cpu optimize file outty = withContext $ \context -> do - initializeAllTargets - (target, _) <- failInIO $ lookupTarget Nothing triple - withTargetOptions $ \options -> - 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 . MO.withModuleFromAST context ast $ \m -> - do let opts = PM.defaultCuratedPassSetSpec - { PM.optLevel = Just optimize - , PM.simplifyLibCalls = Just True - , PM.useInlinerWithThreshold = Just 225 - } - when (optimize /= 0) $ PM.withPassManager opts $ void . flip PM.runPassManager m - outputModule tm file outty m - case result of - Right _ -> return () - Left msg -> ierror msg - -failInIO :: ErrorT String IO a -> IO a -failInIO = either fail return <=< runErrorT - -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 - defs <- ( "llvm" "libidris_rts.a") <$> getDataDir - exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file] - when (exit /= ExitSuccess) $ ierror "FAILURE: Linking" -outputModule _ _ MavenProject _ = ierror "FAILURE: unsupported output type" - -withTmpFile :: (FilePath -> IO a) -> IO a -withTmpFile f = do - (path, handle) <- tempfile - hClose handle - result <- f path - removeFile path - return result - -ierror :: String -> a -ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg - -mainDef :: Global -mainDef = - functionDefaults - { G.returnType = IntegerType 32 - , G.parameters = - ([ Parameter (IntegerType 32) (Name "argc") [] - , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") [] - ], False) - , G.name = Name "main" - , G.basicBlocks = - [ BasicBlock (UnName 0) - [ Do $ simpleCall "GC_init" [] -- Initialize Boehm GC - , Do $ simpleCall "__gmp_set_memory_functions" - [ ConstantOperand . C.GlobalReference . Name $ "__idris_gmpMalloc" - , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpRealloc" - , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpFree" - ] - , Do $ Store False (ConstantOperand . C.GlobalReference . Name $ "__idris_argc") - (LocalReference (Name "argc")) Nothing 0 [] - , Do $ Store False (ConstantOperand . C.GlobalReference . Name $ "__idris_argv") - (LocalReference (Name "argv")) Nothing 0 [] - , UnName 1 := idrCall "{runMain0}" [] ] - (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []) - ]} - -initDefs :: Target -> [Definition] -initDefs tgt = - [ TypeDefinition (Name "valTy") - (Just $ StructureType False - [ IntegerType 32 - , ArrayType 0 (PointerType valueType (AddrSpace 0)) - ]) - , TypeDefinition (Name "mpz") - (Just $ StructureType False - [ IntegerType 32 - , IntegerType 32 - , PointerType intPtr (AddrSpace 0) - ]) - , GlobalDefinition $ globalVariableDefaults - { G.name = Name "__idris_intFmtStr" - , G.linkage = L.Internal - , G.isConstant = True - , G.hasUnnamedAddr = True - , G.type' = ArrayType 5 (IntegerType 8) - , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0]) - } - , rtsFun "intStr" ptrI8 [IntegerType 64] - [ BasicBlock (UnName 0) - [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)] - , UnName 2 := simpleCall "snprintf" - [ LocalReference (UnName 1) - , ConstantOperand (C.Int (tgtWordSize tgt) 21) - , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0] - , LocalReference (UnName 0) - ] - ] - (Do $ Ret (Just (LocalReference (UnName 1))) []) - ] - , GlobalDefinition $ globalVariableDefaults - { G.name = Name "__idris_floatFmtStr" - , G.linkage = L.Internal - , G.isConstant = True - , G.hasUnnamedAddr = True - , G.type' = ArrayType 5 (IntegerType 8) - , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%g" ++ [C.Int 8 0]) - } - , rtsFun "floatStr" ptrI8 [FloatingPointType 64 IEEE] - [ BasicBlock (UnName 0) - [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)] - , UnName 2 := simpleCall "snprintf" - [ LocalReference (UnName 1) - , ConstantOperand (C.Int (tgtWordSize tgt) 21) - , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_floatFmtStr") [C.Int 32 0, C.Int 32 0] - , LocalReference (UnName 0) - ] - ] - (Do $ Ret (Just (LocalReference (UnName 1))) []) - ] - , exfun "llvm.sin.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "llvm.cos.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "llvm.pow.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "llvm.ceil.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "llvm.floor.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "llvm.exp.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "llvm.log.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "llvm.sqrt.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "tan" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "asin" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "acos" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "atan" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False - , exfun "llvm.trap" VoidType [] False - -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i32" VoidType [ptrI8, ptrI8, IntegerType 32, IntegerType 32, IntegerType 1] False - -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i64" VoidType [ptrI8, ptrI8, IntegerType 64, IntegerType 32, IntegerType 1] False - , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False - , exfun "llvm.invariant.start" (PointerType (StructureType False []) (AddrSpace 0)) [IntegerType 64, ptrI8] False - , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True - , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False - , exfun "strlen" intPtr [ptrI8] False - , exfun "GC_init" VoidType [] False - , exfun "GC_malloc" ptrI8 [intPtr] False - , exfun "GC_malloc_atomic" ptrI8 [intPtr] False - , exfun "__gmp_set_memory_functions" VoidType - [ PointerType (FunctionType ptrI8 [intPtr] False) (AddrSpace 0) - , PointerType (FunctionType ptrI8 [ptrI8, intPtr, intPtr] False) (AddrSpace 0) - , PointerType (FunctionType VoidType [ptrI8, intPtr] False) (AddrSpace 0) - ] False - , exfun "__gmpz_init" VoidType [pmpz] False - , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False - , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False - , exfun "__gmpz_get_ui" intPtr [pmpz] False - , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False - , exfun "__gmpz_fdiv_q_2exp" VoidType [pmpz, pmpz, intPtr] False - , exfun "__gmpz_mul_2exp" VoidType [pmpz, pmpz, intPtr] False - , exfun "__gmpz_get_d" (FloatingPointType 64 IEEE) [pmpz] False - , exfun "__gmpz_set_d" VoidType [pmpz, FloatingPointType 64 IEEE] False - , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False - , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False - , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False - , exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False - , exfun "__idris_readStr" ptrI8 [ptrI8] False -- Actually pointer to FILE, but it's opaque anyway - , exfun "__idris_gmpMalloc" ptrI8 [intPtr] False - , exfun "__idris_gmpRealloc" ptrI8 [ptrI8, intPtr, intPtr] False - , 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 - , exVar "__idris_argc" (IntegerType 32) - , exVar "__idris_argv" (PointerType ptrI8 (AddrSpace 0)) - , GlobalDefinition mainDef - ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"] - where - intPtr = IntegerType (tgtWordSize tgt) - ptrI8 = PointerType (IntegerType 8) (AddrSpace 0) - pmpz = PointerType mpzTy (AddrSpace 0) - - mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False - - rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition - rtsFun name rty argtys def = - GlobalDefinition $ functionDefaults - { G.linkage = L.Internal - , G.returnType = rty - , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False) - , G.name = Name $ "__idris_" ++ name - , G.basicBlocks = def - } - - exfun :: String -> Type -> [Type] -> Bool -> Definition - exfun name rty argtys vari = - GlobalDefinition $ functionDefaults - { G.returnType = rty - , G.name = Name name - , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari) - } - exVar :: String -> Type -> Definition - exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty } - -isApple :: Target -> Bool -isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t - -stdinName, stdoutName, stderrName :: Target -> String -stdinName t | isApple t = "__stdinp" -stdinName _ = "stdin" -stdoutName t | isApple t = "__stdoutp" -stdoutName _ = "stdout" -stderrName t | isApple t = "__stderrp" -stderrName _ = "stderr" - -getStdIn, getStdOut, getStdErr :: Codegen Operand -getStdIn = ConstantOperand . C.GlobalReference . Name . stdinName <$> asks target -getStdOut = ConstantOperand . C.GlobalReference . Name . stdoutName <$> asks target -getStdErr = ConstantOperand . C.GlobalReference . Name . stderrName <$> asks target - -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 initialMGS - -valueType :: Type -valueType = NamedTypeReference (Name "valTy") - -nullValue :: C.Constant -nullValue = C.Null (PointerType valueType (AddrSpace 0)) - -primTy :: Type -> Type -primTy inner = StructureType False [IntegerType 32, inner] - -mpzTy :: Type -mpzTy = NamedTypeReference (Name "mpz") - -conType :: Word64 -> Type -conType nargs = StructureType False - [ IntegerType 32 - , ArrayType nargs (PointerType valueType (AddrSpace 0)) - ] - -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 <- gets mgsNextGlobalName - existingForeignSyms <- gets mgsForeignSyms - tgt <- ask - 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) existingForeignSyms) - entryTerm = case bbs of - [] -> Do $ Ret Nothing [] - BasicBlock n _ _:_ -> Do $ Br n [] - tell globals - put (MGS { mgsNextGlobalName = nextGlobal', mgsForeignSyms = foreignSyms' }) - return . GlobalDefinition $ functionDefaults - { G.linkage = L.Internal - , G.callingConvention = CC.Fast - , G.name = Name (show name) - , G.returnType = PointerType valueType (AddrSpace 0) - , G.parameters = (flip map argNames $ \argName -> - Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) [] - , False) - , G.basicBlocks = - BasicBlock (Name "entry") - (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas) - entryTerm - : bbs - } - -type CGW = ([(Name, Type)], [BasicBlock], [Definition]) - -type Env = [Maybe Operand] - -data CGS = CGS { nextName :: Word - , nextGlobalName :: Word - , currentBlockName :: Name - , instAccum :: [Named Instruction] - , lexenv :: Env - , foreignSyms :: Map String (FType, [FType]) - } - -data CGR = CGR { target :: Target - , funcName :: String } - -type Codegen = RWS CGR CGW CGS - -getFuncName :: Codegen String -getFuncName = asks funcName - -getGlobalUnName :: Codegen Name -getGlobalUnName = do - i <- gets nextGlobalName - modify $ \s -> s { nextGlobalName = 1 + i } - return (UnName i) - -getUnName :: Codegen Name -getUnName = do - i <- gets nextName - modify $ \s -> s { nextName = 1 + i } - return (UnName i) - -getName :: String -> Codegen Name -getName n = do - i <- gets nextName - modify $ \s -> s { nextName = 1 + i } - return (Name $ n ++ show i) - -alloca :: Name -> Type -> Codegen () -alloca n t = tell ([(n, t)], [], []) - -terminate :: Terminator -> Codegen () -terminate term = do - name <- gets currentBlockName - insts <- gets instAccum - modify $ \s -> s { instAccum = ierror "Not in a block" - , currentBlockName = ierror "Not in a block" } - tell ([], [BasicBlock name insts (Do term)], []) - -newBlock :: Name -> Codegen () -newBlock name = modify $ \s -> s { instAccum = [] - , currentBlockName = name - } - -inst :: Instruction -> Codegen Operand -inst i = do - n <- getUnName - modify $ \s -> s { instAccum = instAccum s ++ [n := i] } - return $ LocalReference n - -ninst :: String -> Instruction -> Codegen Operand -ninst name i = do - n <- getName name - modify $ \s -> s { instAccum = instAccum s ++ [n := i] } - return $ LocalReference n - -inst' :: Instruction -> Codegen () -inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] } - -insts :: [Named Instruction] -> Codegen () -insts is = modify $ \s -> s { instAccum = instAccum s ++ is } - -var :: LVar -> Codegen (Maybe Operand) -var (Loc level) = (!! level) <$> gets lexenv -var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n - -binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand) -binds vals cg = do - envLen <- length <$> gets lexenv - modify $ \s -> s { lexenv = lexenv s ++ vals } - value <- cg - modify $ \s -> s { lexenv = take envLen $ lexenv s } - return value - -replaceElt :: Int -> a -> [a] -> [a] -replaceElt _ val [] = error "replaceElt: Ran out of list" -replaceElt 0 val (x:xs) = val:xs -replaceElt n val (x:xs) = x : replaceElt (n-1) val xs - -alloc' :: Operand -> Codegen Operand -alloc' size = inst $ simpleCall "GC_malloc" [size] - -allocAtomic' :: Operand -> Codegen Operand -allocAtomic' size = inst $ simpleCall "GC_malloc_atomic" [size] - -alloc :: Type -> Codegen Operand -alloc ty = do - size <- sizeOf ty - mem <- alloc' size - inst $ BitCast mem (PointerType ty (AddrSpace 0)) [] - -allocAtomic :: Type -> Codegen Operand -allocAtomic ty = do - size <- sizeOf ty - mem <- allocAtomic' size - inst $ BitCast mem (PointerType ty (AddrSpace 0)) [] - -sizeOf :: Type -> Codegen Operand -sizeOf ty = ConstantOperand . C.PtrToInt - (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1]) - . IntegerType <$> getWordSize - -loadInv :: Operand -> Instruction -loadInv ptr = Load False ptr Nothing 0 [("invariant.load", MetadataNode [])] - -tgtWordSize :: Target -> Word32 -tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) = - fst . fromJust $ M.lookup (AddrSpace 0) l - -getWordSize :: Codegen Word32 -getWordSize = tgtWordSize <$> asks target - -cgExpr :: SExp -> Codegen (Maybe Operand) -cgExpr (SV v) = var v -cgExpr (SApp tailcall fname args) = do - argSlots <- mapM var args - case sequence argSlots of - Nothing -> return Nothing - Just argVals -> do - fn <- var (Glob fname) - Just <$> inst ((idrCall (show fname) argVals) { isTailCall = tailcall }) -cgExpr (SLet _ varExpr bodyExpr) = do - val <- cgExpr varExpr - binds [val] $ cgExpr bodyExpr -cgExpr (SUpdate (Loc level) expr) = do - val <- cgExpr expr - modify $ \s -> s { lexenv = replaceElt level val (lexenv s) } - return val -cgExpr (SUpdate x expr) = cgExpr expr -cgExpr (SCon _ tag name args) = do - argSlots <- mapM var args - case sequence argSlots of - Nothing -> return Nothing - Just argVals -> do - let ty = conType . fromIntegral . length $ argVals - con <- alloc ty - tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] - inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 [] - forM_ (zip argVals [0..]) $ \(arg, i) -> do - ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0) - , ConstantOperand (C.Int 32 1) - , ConstantOperand (C.Int 32 i)] [] - inst' $ Store False ptr arg Nothing 0 [] - ptrI8 <- inst $ BitCast con (PointerType (IntegerType 8) (AddrSpace 0)) [] - inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8] - Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) []) -cgExpr (SCase _ inspect alts) = do - val <- var inspect - case val of - Nothing -> return Nothing - Just v -> cgCase v alts -cgExpr (SChkCase inspect alts) = do - mval <- var inspect - case mval of - Nothing -> return Nothing - Just val -> - do endBBN <- getName "endChkCase" - notNullBBN <- getName "notNull" - originBlock <- gets currentBlockName - isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) [] - terminate $ CondBr isNull endBBN notNullBBN [] - newBlock notNullBBN - ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) [] - flag <- inst $ Load False ptr Nothing 0 [] - isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) [] - conBBN <- getName "constructor" - terminate $ CondBr isVal endBBN conBBN [] - newBlock conBBN - result <- cgCase val alts - caseExitBlock <- gets currentBlockName - case result of - Nothing -> do - terminate $ Unreachable [] - newBlock endBBN - return $ Just val - Just caseVal -> do - terminate $ Br endBBN [] - newBlock endBBN - Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) - [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] []) -cgExpr (SProj conVar idx) = do - val <- var conVar - case val of - Nothing -> return Nothing - Just v -> - do ptr <- inst $ GetElementPtr True v - [ ConstantOperand (C.Int 32 0) - , ConstantOperand (C.Int 32 1) - , ConstantOperand (C.Int 32 (fromIntegral idx)) - ] [] - Just <$> inst (Load False ptr Nothing 0 []) -cgExpr (SConst c) = Just <$> cgConst c -cgExpr (SForeign LANG_C rty fname args) = do - func <- ensureCDecl fname rty (map fst args) - argVals <- forM args $ \(fty, v) -> do - v' <- var v - case v' of - Just val -> return $ Just (fty, val) - Nothing -> return Nothing - case sequence argVals of - Nothing -> return Nothing - Just argVals' -> do - argUVals <- mapM (uncurry unbox) argVals' - result <- inst Call { isTailCall = False - , callingConvention = CC.C - , returnAttributes = [] - , function = Right func - , arguments = map (\v -> (v, [])) argUVals - , functionAttributes = [] - , metadata = [] - } - Just <$> box rty result -cgExpr (SOp fn args) = do - argVals <- mapM var args - case sequence argVals of - Just ops -> Just <$> cgOp fn ops - Nothing -> return Nothing -cgExpr SNothing = return . Just . ConstantOperand $ nullValue -cgExpr (SError msg) = do - str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8)) - (cgConst' (TT.Str (msg ++ "\n"))) - inst' $ simpleCall "putErr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0 - , C.Int 32 0]] - inst' Call { isTailCall = True - , callingConvention = CC.C - , returnAttributes = [] - , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap" - , arguments = [] - , functionAttributes = [A.NoReturn] - , metadata = [] - } - return Nothing - -cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand) -cgCase val alts = - case find isConstCase alts of - Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts - Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts - Just (SConstCase _ _) -> cgPrimCase val defExp constAlts - Nothing -> cgConCase val defExp conAlts - where - defExp = getDefExp =<< find isDefCase alts - constAlts = filter isConstCase alts - conAlts = filter isConCase alts - - isConstCase (SConstCase {}) = True - isConstCase _ = False - - isConCase (SConCase {}) = True - isConCase _ = False - - isDefCase (SDefaultCase _) = True - isDefCase _ = False - - getDefExp (SDefaultCase e) = Just e - getDefExp _ = Nothing - -cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) -cgPrimCase caseValPtr defExp alts = do - let caseTy = case head alts of - SConstCase (TT.I _) _ -> IntegerType 32 - SConstCase (TT.B8 _) _ -> IntegerType 8 - SConstCase (TT.B16 _) _ -> IntegerType 16 - SConstCase (TT.B32 _) _ -> IntegerType 32 - SConstCase (TT.B64 _) _ -> IntegerType 64 - SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE - SConstCase (TT.Ch _) _ -> IntegerType 32 - realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) [] - valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] [] - caseVal <- inst $ Load False valPtr Nothing 0 [] - defBlockName <- getName "default" - exitBlockName <- getName "caseExit" - namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts - terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) [] - initEnv <- gets lexenv - defResult <- cgDefaultAlt exitBlockName defBlockName defExp - results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp - finishCase initEnv exitBlockName (defResult:results) - -cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) -cgConCase con defExp alts = do - tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] - tag <- inst $ Load False tagPtr Nothing 0 [] - defBlockName <- getName "default" - exitBlockName <- getName "caseExit" - namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts - terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) -> - (C.Int 32 (fromIntegral tag), n)) namedAlts) [] - initEnv <- gets lexenv - defResult <- cgDefaultAlt exitBlockName defBlockName defExp - results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) -> - cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp - finishCase initEnv exitBlockName (defResult:results) - -cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) -cgChainCase caseValPtr defExp alts = do - let (caseTy, comparator) = - case head alts of - SConstCase (TT.BI _) _ -> (FArith (ATInt ITBig), "__gmpz_cmp") - SConstCase (TT.Str _) _ -> (FString, "strcmp") - caseVal <- unbox caseTy caseValPtr - defBlockName <- getName "default" - exitBlockName <- getName "caseExit" - namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts - initEnv <- gets lexenv - results <- forM namedAlts $ \(name, SConstCase c e) -> - do const <- unbox caseTy =<< cgConst c - cmp <- inst $ simpleCall comparator [const, caseVal] - cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) [] - elseName <- getName "else" - terminate $ CondBr cmpResult name elseName [] - result <- cgAlt initEnv exitBlockName name Nothing e - newBlock elseName - return result - modify $ \s -> s { lexenv = initEnv } - fname <- getFuncName - defaultVal <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) defExp) - defaultBlock <- gets currentBlockName - defaultEnv <- gets lexenv - defResult <- case defaultVal of - Just v -> do - terminate $ Br exitBlockName [] - return $ Just (v, defaultBlock, defaultEnv) - Nothing -> do - terminate $ Unreachable [] - return Nothing - finishCase initEnv exitBlockName (defResult:results) - -finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand) -finishCase initEnv exitBlockName results = do - let definedResults = mapMaybe id results - case definedResults of - [] -> do modify $ \s -> s { lexenv = initEnv } - return Nothing - xs -> do - newBlock exitBlockName - mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs - Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) - (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) []) - - -cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env)) -cgDefaultAlt exitName name exp = do - newBlock name - fname <- getFuncName - val <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) exp) - env <- gets lexenv - block <- gets currentBlockName - case val of - Just v -> - do terminate $ Br exitName [] - return $ Just (v, block, env) - Nothing -> - do terminate $ Unreachable [] - return Nothing - -cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp - -> Codegen (Maybe (Operand, Name, Env)) -cgAlt initEnv exitBlockName name destr exp = do - modify $ \s -> s { lexenv = initEnv } - newBlock name - locals <- case destr of - Nothing -> return [] - Just (con, argns) -> - forM (zip argns [0..]) $ \(argName, i) -> - do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0) - , ConstantOperand (C.Int 32 1) - , ConstantOperand (C.Int 32 i)] [] - Just <$> ninst argName (Load False ptr Nothing 0 []) - altVal <- binds locals $ cgExpr exp - altEnv <- gets lexenv - altBlock <- gets currentBlockName - case altVal of - Just v -> do - terminate $ Br exitBlockName [] - return $ Just (v, altBlock, altEnv) - Nothing -> do - terminate $ Unreachable [] - return Nothing - -mergeEnvs :: [(Name, Env)] -> Codegen () -mergeEnvs es = do - let vars = transpose - . map (\(block, env) -> map (\x -> (x, block)) env) - $ es - env <- forM vars $ \var -> - case var of - [] -> ierror "mergeEnvs: impossible" - [(v, _)] -> return v - vs@((v, _):_) - | all (== v) (map fst vs) -> return v - | otherwise -> - let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in - Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid []) - modify $ \s -> s { lexenv = env } - -nameAlt :: Name -> SAlt -> Codegen Name -nameAlt d (SDefaultCase _) = return d -nameAlt _ (SConCase _ _ name _ _) = getName (show name) -nameAlt _ (SConstCase const _) = getName (show const) - -isHeapFTy :: FType -> Bool -isHeapFTy f = elem f [FString, FPtr, FAny, FArith (ATInt ITBig)] - -box :: FType -> Operand -> Codegen Operand -box FUnit _ = return $ ConstantOperand nullValue -box fty fval = do - let ty = primTy (ftyToTy fty) - val <- if isHeapFTy fty then alloc ty else allocAtomic ty - tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] - valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] [] - inst' $ Store False tagptr (ConstantOperand (C.Int 32 (-1))) Nothing 0 [] - inst' $ Store False valptr fval Nothing 0 [] - ptrI8 <- inst $ BitCast val (PointerType (IntegerType 8) (AddrSpace 0)) [] - inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8] - inst $ BitCast val (PointerType valueType (AddrSpace 0)) [] - -unbox :: FType -> Operand -> Codegen Operand -unbox FUnit x = return x -unbox fty bval = do - val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) [] - fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] [] - inst $ Load False fvalptr Nothing 0 [] - -cgConst' :: TT.Const -> C.Constant -cgConst' (TT.I i) = C.Int 32 (fromIntegral i) -cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i) -cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i) -cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i) -cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i) -cgConst' (TT.B8V v) = C.Vector (map ((C.Int 8) . fromIntegral) . V.toList $ v) -cgConst' (TT.B16V v) = C.Vector (map ((C.Int 16) . fromIntegral) . V.toList $ v) -cgConst' (TT.B32V v) = C.Vector (map ((C.Int 32) . fromIntegral) . V.toList $ v) -cgConst' (TT.B64V v) = C.Vector (map ((C.Int 64) . fromIntegral) . V.toList $ v) - -cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0]) -cgConst' (TT.Fl f) = C.Float (F.Double f) -cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c -cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0]) -cgConst' x = ierror $ "Unsupported constant: " ++ show x - -cgConst :: TT.Const -> Codegen Operand -cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c) -cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c) -cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c) -cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c) -cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c) -cgConst c@(TT.B8V v) = box (FArith (ATInt (ITVec IT8 (V.length v)))) (ConstantOperand $ cgConst' c) -cgConst c@(TT.B16V v) = box (FArith (ATInt (ITVec IT16 (V.length v)))) (ConstantOperand $ cgConst' c) -cgConst c@(TT.B32V v) = box (FArith (ATInt (ITVec IT32 (V.length v)))) (ConstantOperand $ cgConst' c) -cgConst c@(TT.B64V v) = box (FArith (ATInt (ITVec IT64 (V.length v)))) (ConstantOperand $ cgConst' c) -cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c) -cgConst c@(TT.Ch _) = box (FArith (ATInt ITChar)) (ConstantOperand $ cgConst' c) -cgConst c@(TT.Str s) = do - str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c) - box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0]) -cgConst c@(TT.BI i) = do - let stringRepLen = (if i < 0 then 2 else 1) + fromInteger (numDigits 10 i) - str <- addGlobal' (ArrayType stringRepLen (IntegerType 8)) (cgConst' c) - mpz <- alloc mpzTy - inst $ simpleCall "__gmpz_init_set_str" [mpz - , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0] - , ConstantOperand $ C.Int 32 10 - ] - box (FArith (ATInt ITBig)) mpz -cgConst x = return $ ConstantOperand nullValue - -numDigits :: Integer -> Integer -> Integer -numDigits b n = 1 + fst (ilog b n) where - ilog b n - | n < b = (0, n) - | otherwise = let (e, r) = ilog (b*b) n - in if r < b then (2*e, r) else (2*e+1, r `div` b) - -addGlobal :: Global -> Codegen () -addGlobal def = tell ([], [], [GlobalDefinition def]) - -addGlobal' :: Type -> C.Constant -> Codegen C.Constant -addGlobal' ty val = do - name <- getGlobalUnName - addGlobal $ globalVariableDefaults - { G.name = name - , G.linkage = L.Internal - , G.hasUnnamedAddr = True - , G.isConstant = True - , G.type' = ty - , G.initializer = Just val - } - return . C.GlobalReference $ name - - -ensureCDecl :: String -> FType -> [FType] -> Codegen Operand -ensureCDecl name rty argtys = do - syms <- gets foreignSyms - 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 -ffunDecl name rty argtys = - functionDefaults - { G.returnType = ftyToTy rty - , G.name = Name name - , G.parameters = (flip map argtys $ \fty -> - Parameter (ftyToTy fty) (UnName 0) [] - , False) - } - -ftyToTy :: FType -> Type -ftyToTy (FArith (ATInt ITNative)) = IntegerType 32 -ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0) -ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty) -ftyToTy (FArith (ATInt (ITVec e c))) - = VectorType (fromIntegral c) (IntegerType (fromIntegral $ nativeTyWidth e)) -ftyToTy (FArith (ATInt ITChar)) = IntegerType 32 -ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE -ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0) -ftyToTy FUnit = VoidType -ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0) -ftyToTy FAny = valueType - --- Only use when known not to be ITBig -itWidth :: IntTy -> Word32 -itWidth ITNative = 32 -itWidth ITChar = 32 -itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x -itWidth x = ierror $ "itWidth: " ++ show x - -itConst :: IntTy -> Integer -> C.Constant -itConst (ITFixed n) x = C.Int (fromIntegral $ nativeTyWidth n) x -itConst ITNative x = itConst (ITFixed IT32) x -itConst ITChar x = itConst (ITFixed IT32) x -itConst (ITVec elts size) x = C.Vector (replicate size (itConst (ITFixed elts) x)) - -cgOp :: PrimFn -> [Operand] -> Codegen Operand -cgOp (LTrunc ITBig ity) [x] = do - nx <- unbox (FArith (ATInt ITBig)) x - val <- inst $ simpleCall "mpz_get_ull" [nx] - v <- case ity of - (ITFixed IT64) -> return val - _ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) [] - box (FArith (ATInt ity)) v -cgOp (LZExt from ITBig) [x] = do - nx <- unbox (FArith (ATInt from)) x - nx' <- case from of - (ITFixed IT64) -> return nx - _ -> inst $ ZExt nx (IntegerType 64) [] - mpz <- alloc mpzTy - inst' $ simpleCall "mpz_init_set_ull" [mpz, nx'] - box (FArith (ATInt ITBig)) mpz -cgOp (LSExt from ITBig) [x] = do - nx <- unbox (FArith (ATInt from)) x - nx' <- case from of - (ITFixed IT64) -> return nx - _ -> inst $ SExt nx (IntegerType 64) [] - mpz <- alloc mpzTy - inst' $ simpleCall "mpz_init_set_sll" [mpz, nx'] - box (FArith (ATInt ITBig)) mpz - --- ITChar, ITNative, and IT32 all share representation -cgOp (LChInt ITNative) [x] = return x -cgOp (LIntCh ITNative) [x] = return x - -cgOp (LSLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y -cgOp (LSLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y -cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y -cgOp (LSGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y -cgOp (LSGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y -cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y -cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y -cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y -cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y -cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y -cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y -cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y -cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y -cgOp (LCompl ITBig) [x] = mpzUn "com" x -cgOp (LSHL ITBig) [x,y] = mpzBit "mul_2exp" x y -cgOp (LASHR ITBig) [x,y] = mpzBit "fdiv_q_2exp" x y - -cgOp (LTrunc ITNative (ITFixed to)) [x] - | 32 >= nativeTyWidth to = iCoerce Trunc IT32 to x -cgOp (LZExt ITNative (ITFixed to)) [x] - | 32 <= nativeTyWidth to = iCoerce ZExt IT32 to x -cgOp (LSExt ITNative (ITFixed to)) [x] - | 32 <= nativeTyWidth to = iCoerce SExt IT32 to x - -cgOp (LTrunc (ITFixed from) ITNative) [x] - | nativeTyWidth from >= 32 = iCoerce Trunc from IT32 x -cgOp (LZExt (ITFixed from) ITNative) [x] - | nativeTyWidth from <= 32 = iCoerce ZExt from IT32 x -cgOp (LSExt (ITFixed from) ITNative) [x] - | nativeTyWidth from <= 32 = iCoerce SExt from IT32 x - -cgOp (LTrunc (ITFixed from) (ITFixed to)) [x] - | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x -cgOp (LZExt (ITFixed from) (ITFixed to)) [x] - | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x -cgOp (LSExt (ITFixed from) (ITFixed to)) [x] - | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x - -cgOp (LSLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y -cgOp (LSLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y -cgOp (LLt ity) [x,y] = iCmp ity IPred.ULT x y -cgOp (LLe ity) [x,y] = iCmp ity IPred.ULE x y -cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y -cgOp (LSGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y -cgOp (LSGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y -cgOp (LGe ity) [x,y] = iCmp ity IPred.UGE x y -cgOp (LGt ity) [x,y] = iCmp ity IPred.UGT x y -cgOp (LPlus ty@(ATInt _)) [x,y] = binary ty x y (Add False False) -cgOp (LMinus ty@(ATInt _)) [x,y] = binary ty x y (Sub False False) -cgOp (LTimes ty@(ATInt _)) [x,y] = binary ty x y (Mul False False) -cgOp (LSDiv ty@(ATInt _)) [x,y] = binary ty x y (SDiv False) -cgOp (LSRem ty@(ATInt _)) [x,y] = binary ty x y SRem -cgOp (LUDiv ity) [x,y] = binary (ATInt ity) x y (UDiv False) -cgOp (LURem ity) [x,y] = binary (ATInt ity) x y URem -cgOp (LAnd ity) [x,y] = binary (ATInt ity) x y And -cgOp (LOr ity) [x,y] = binary (ATInt ity) x y Or -cgOp (LXOr ity) [x,y] = binary (ATInt ity) x y Xor -cgOp (LCompl ity) [x] = unary (ATInt ity) x (Xor . ConstantOperand $ itConst ity (-1)) -cgOp (LSHL ity) [x,y] = binary (ATInt ity) x y (Shl False False) -cgOp (LLSHR ity) [x,y] = binary (ATInt ity) x y (LShr False) -cgOp (LASHR ity) [x,y] = binary (ATInt ity) x y (AShr False) - -cgOp (LSLt ATFloat) [x,y] = fCmp FPred.OLT x y -cgOp (LSLe ATFloat) [x,y] = fCmp FPred.OLE x y -cgOp (LEq ATFloat) [x,y] = fCmp FPred.OEQ x y -cgOp (LSGe ATFloat) [x,y] = fCmp FPred.OGE x y -cgOp (LSGt ATFloat) [x,y] = fCmp FPred.OGT x y -cgOp (LPlus ATFloat) [x,y] = binary ATFloat x y FAdd -cgOp (LMinus ATFloat) [x,y] = binary ATFloat x y FSub -cgOp (LTimes ATFloat) [x,y] = binary ATFloat x y FMul -cgOp (LSDiv ATFloat) [x,y] = binary ATFloat x y FDiv - -cgOp LFExp [x] = nunary ATFloat "llvm.exp.f64" x -cgOp LFLog [x] = nunary ATFloat "llvm.log.f64" x -cgOp LFSin [x] = nunary ATFloat "llvm.sin.f64" x -cgOp LFCos [x] = nunary ATFloat "llvm.cos.f64" x -cgOp LFTan [x] = nunary ATFloat "tan" x -cgOp LFASin [x] = nunary ATFloat "asin" x -cgOp LFACos [x] = nunary ATFloat "acos" x -cgOp LFATan [x] = nunary ATFloat "atan" x -cgOp LFSqrt [x] = nunary ATFloat "llvm.sqrt.f64" x -cgOp LFFloor [x] = nunary ATFloat "llvm.floor.f64" x -cgOp LFCeil [x] = nunary ATFloat "llvm.ceil.f64" x - -cgOp (LIntFloat ITBig) [x] = do - x' <- unbox (FArith (ATInt ITBig)) x - uflt <- inst $ simpleCall "__gmpz_get_d" [ x' ] - box (FArith ATFloat) uflt - -cgOp (LIntFloat ity) [x] = do - x' <- unbox (FArith (ATInt ity)) x - x'' <- inst $ SIToFP x' (FloatingPointType 64 IEEE) [] - box (FArith ATFloat) x'' - -cgOp (LFloatInt ITBig) [x] = do - x' <- unbox (FArith ATFloat) x - z <- alloc mpzTy - inst' $ simpleCall "__gmpz_init" [z] - inst' $ simpleCall "__gmpz_set_d" [ z, x' ] - box (FArith (ATInt ITBig)) z - -cgOp (LFloatInt ity) [x] = do - x' <- unbox (FArith ATFloat) x - x'' <- inst $ FPToSI x' (ftyToTy $ cmpResultTy ity) [] - box (FArith (ATInt ity)) x'' - -cgOp LFloatStr [x] = do - x' <- unbox (FArith ATFloat) x - ustr <- inst (idrCall "__idris_floatStr" [x']) - box FString ustr - -cgOp LNoOp xs = return $ last xs - -cgOp (LMkVec ety c) xs | c == length xs = do - nxs <- mapM (unbox (FArith (ATInt (ITFixed ety)))) xs - vec <- foldM (\v (e, i) -> inst $ InsertElement v e (ConstantOperand (C.Int 32 i)) []) - (ConstantOperand $ C.Vector (replicate c (C.Undef (IntegerType . fromIntegral $ nativeTyWidth ety)))) - (zip nxs [0..]) - box (FArith (ATInt (ITVec ety c))) vec - -cgOp (LIdxVec ety c) [v,i] = do - nv <- unbox (FArith (ATInt (ITVec ety c))) v - ni <- unbox (FArith (ATInt (ITFixed IT32))) i - elt <- inst $ ExtractElement nv ni [] - box (FArith (ATInt (ITFixed ety))) elt - -cgOp (LUpdateVec ety c) [v,i,e] = do - let fty = FArith (ATInt (ITVec ety c)) - nv <- unbox fty v - ni <- unbox (FArith (ATInt (ITFixed IT32))) i - ne <- unbox (FArith (ATInt (ITFixed ety))) e - nv' <- inst $ InsertElement nv ne ni [] - box fty nv' - -cgOp (LBitCast from to) [x] = do - nx <- unbox (FArith from) x - nx' <- inst $ BitCast nx (ftyToTy (FArith to)) [] - box (FArith to) nx' - -cgOp LStrEq [x,y] = do - x' <- unbox FString x - y' <- unbox FString y - cmp <- inst $ simpleCall "strcmp" [x', y'] - flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) [] - val <- inst $ ZExt flag (IntegerType 32) [] - box (FArith (ATInt (ITFixed IT32))) val - -cgOp LStrLt [x,y] = do - nx <- unbox FString x - ny <- unbox FString y - cmp <- inst $ simpleCall "strcmp" [nx, ny] - flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) [] - val <- inst $ ZExt flag (IntegerType 32) [] - box (FArith (ATInt (ITFixed IT32))) val - -cgOp (LIntStr ITBig) [x] = do - x' <- unbox (FArith (ATInt ITBig)) x - ustr <- inst $ simpleCall "__gmpz_get_str" - [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0))) - , ConstantOperand (C.Int 32 10) - , x' - ] - box FString ustr -cgOp (LIntStr ity) [x] = do - x' <- unbox (FArith (ATInt ity)) x - x'' <- if itWidth ity < 64 - then inst $ SExt x' (IntegerType 64) [] - else return x' - box FString =<< inst (idrCall "__idris_intStr" [x'']) -cgOp (LStrInt ITBig) [s] = do - ns <- unbox FString s - mpz <- alloc mpzTy - inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10] - box (FArith (ATInt ITBig)) mpz -cgOp (LStrInt ity) [s] = do - ns <- unbox FString s - nx <- inst $ simpleCall "strtoll" - [ns - , ConstantOperand $ C.Null (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) - , ConstantOperand $ C.Int 32 10 - ] - nx' <- case ity of - (ITFixed IT64) -> return nx - _ -> inst $ Trunc nx (IntegerType (itWidth ity)) [] - box (FArith (ATInt ity)) nx' - -cgOp LStrConcat [x,y] = cgStrCat x y - -cgOp LStrCons [c,s] = do - nc <- unbox (FArith (ATInt ITChar)) c - ns <- unbox FString s - nc' <- inst $ Trunc nc (IntegerType 8) [] - r <- inst $ simpleCall "__idris_strCons" [nc', ns] - box FString r - -cgOp LStrHead [c] = do - s <- unbox FString c - c <- inst $ Load False s Nothing 0 [] - c' <- inst $ ZExt c (IntegerType 32) [] - box (FArith (ATInt ITChar)) c' - -cgOp LStrIndex [s, i] = do - ns <- unbox FString s - ni <- unbox (FArith (ATInt (ITFixed IT32))) i - p <- inst $ GetElementPtr True ns [ni] [] - c <- inst $ Load False p Nothing 0 [] - c' <- inst $ ZExt c (IntegerType 32) [] - box (FArith (ATInt ITChar)) c' - -cgOp LStrTail [c] = do - s <- unbox FString c - c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] [] - box FString c - -cgOp LStrLen [s] = do - ns <- unbox FString s - len <- inst $ simpleCall "strlen" [ns] - ws <- getWordSize - len' <- case ws of - 32 -> return len - x | x > 32 -> inst $ Trunc len (IntegerType 32) [] - | x < 32 -> inst $ ZExt len (IntegerType 32) [] - box (FArith (ATInt (ITFixed IT32))) len' - -cgOp LStrRev [s] = do - ns <- unbox FString s - box FString =<< inst (simpleCall "__idris_strRev" [ns]) - -cgOp LReadStr [p] = do - np <- unbox FPtr p - s <- inst $ simpleCall "__idris_readStr" [np] - box FString s - -cgOp LStdIn [] = do - stdin <- getStdIn - ptr <- inst $ loadInv stdin - box FPtr ptr -cgOp LStdOut [] = do - stdout <- getStdOut - ptr <- inst $ loadInv stdout - box FPtr ptr -cgOp LStdErr [] = do - stdErr <- getStdErr - ptr <- inst $ loadInv stdErr - box FPtr ptr - -cgOp LNullPtr [] = box FPtr (ConstantOperand $ C.Null (PointerType (IntegerType 8) (AddrSpace 0))) - -cgOp prim args = ierror $ "Unimplemented primitive: <" ++ show prim ++ ">(" - ++ intersperse ',' (take (length args) ['a'..]) ++ ")" - -iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand -iCoerce _ from to x | from == to = return x -iCoerce operator from to x = do - x' <- unbox (FArith (ATInt (ITFixed from))) x - x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed to)))) [] - box (FArith (ATInt (ITFixed to))) x'' - -cgStrCat :: Operand -> Operand -> Codegen Operand -cgStrCat x y = do - x' <- unbox FString x - y' <- unbox FString y - xlen <- inst $ simpleCall "strlen" [x'] - ylen <- inst $ simpleCall "strlen" [y'] - zlen <- inst $ Add False True xlen ylen [] - ws <- getWordSize - total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) [] - mem <- allocAtomic' total - inst $ simpleCall "memcpy" [mem, x', xlen] - i <- inst $ PtrToInt mem (IntegerType ws) [] - offi <- inst $ Add False True i xlen [] - offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) [] - inst $ simpleCall "memcpy" [offp, y', ylen] - j <- inst $ PtrToInt offp (IntegerType ws) [] - offj <- inst $ Add False True j ylen [] - end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) [] - inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 [] - box FString mem - -binary :: ArithTy -> Operand -> Operand - -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand -binary ty x y instCon = do - nx <- unbox (FArith ty) x - ny <- unbox (FArith ty) y - nr <- inst $ instCon nx ny [] - box (FArith ty) nr - -unary :: ArithTy -> Operand - -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand -unary ty x instCon = do - nx <- unbox (FArith ty) x - nr <- inst $ instCon nx [] - box (FArith ty) nr - -nunary :: ArithTy -> String - -> Operand -> Codegen Operand -nunary ty name x = do - nx <- unbox (FArith ty) x - nr <- inst $ simpleCall name [nx] - box (FArith ty) nr - -iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand -iCmp ity pred x y = do - nx <- unbox (FArith (ATInt ity)) x - ny <- unbox (FArith (ATInt ity)) y - nr <- inst $ ICmp pred nx ny [] - nr' <- inst $ SExt nr (ftyToTy $ cmpResultTy ity) [] - box (cmpResultTy ity) nr' - -fCmp :: FPred.FloatingPointPredicate -> Operand -> Operand -> Codegen Operand -fCmp pred x y = do - nx <- unbox (FArith ATFloat) x - ny <- unbox (FArith ATFloat) y - nr <- inst $ FCmp pred nx ny [] - box (FArith (ATInt (ITFixed IT32))) nr - -cmpResultTy :: IntTy -> FType -cmpResultTy v@(ITVec _ _) = FArith (ATInt v) -cmpResultTy _ = FArith (ATInt (ITFixed IT32)) - -mpzBin :: String -> Operand -> Operand -> Codegen Operand -mpzBin name x y = do - nx <- unbox (FArith (ATInt ITBig)) x - ny <- unbox (FArith (ATInt ITBig)) y - nz <- alloc mpzTy - inst' $ simpleCall "__gmpz_init" [nz] - inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny] - box (FArith (ATInt ITBig)) nz - -mpzBit :: String -> Operand -> Operand -> Codegen Operand -mpzBit name x y = do - nx <- unbox (FArith (ATInt ITBig)) x - ny <- unbox (FArith (ATInt ITBig)) y - bitcnt <- inst $ simpleCall "__gmpz_get_ui" [ny] - nz <- alloc mpzTy - inst' $ simpleCall "__gmpz_init" [nz] - inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, bitcnt] - box (FArith (ATInt ITBig)) nz - -mpzUn :: String -> Operand -> Codegen Operand -mpzUn name x = do - nx <- unbox (FArith (ATInt ITBig)) x - nz <- alloc mpzTy - inst' $ simpleCall "__gmpz_init" [nz] - inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx] - box (FArith (ATInt ITBig)) nz - -mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand -mpzCmp pred x y = do - nx <- unbox (FArith (ATInt ITBig)) x - ny <- unbox (FArith (ATInt ITBig)) y - cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny] - result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) [] - i <- inst $ ZExt result (IntegerType 32) [] - box (FArith (ATInt (ITFixed IT32))) i - -simpleCall :: String -> [Operand] -> Instruction -simpleCall name args = - Call { isTailCall = False - , callingConvention = CC.C - , returnAttributes = [] - , function = Right . ConstantOperand . C.GlobalReference . Name $ name - , arguments = map (\x -> (x, [])) args - , functionAttributes = [] - , metadata = [] - } - -idrCall :: String -> [Operand] -> Instruction -idrCall name args = - Call { isTailCall = False - , callingConvention = CC.Fast - , returnAttributes = [] - , function = Right . ConstantOperand . C.GlobalReference . Name $ name - , arguments = map (\x -> (x, [])) args - , functionAttributes = [] - , metadata = [] - } - -assert :: Operand -> String -> Codegen () -assert condition message = do - passed <- getName "assertPassed" - failed <- getName "assertFailed" - terminate $ CondBr condition passed failed [] - newBlock failed - cgExpr (SError message) - terminate $ Unreachable [] - newBlock passed diff --git a/src/IRTS/Compiler.hs b/src/IRTS/Compiler.hs --- a/src/IRTS/Compiler.hs +++ b/src/IRTS/Compiler.hs @@ -8,14 +8,8 @@ import IRTS.Simplified import IRTS.CodegenCommon import IRTS.CodegenC -import IRTS.CodegenJava import IRTS.DumpBC import IRTS.CodegenJavaScript -#ifdef IDRIS_LLVM -import IRTS.CodegenLLVM -#else -import Util.LLVMStubs -#endif import IRTS.Inliner import Idris.AbsSyntax @@ -94,11 +88,10 @@ Just f -> runIO $ writeFile f (dumpDefuns defuns) triple <- Idris.AbsSyntax.targetTriple cpu <- Idris.AbsSyntax.targetCPU - optimise <- optLevel iLOG "Building output" case checked of - OK c -> do return $ CodegenInfo f outty triple cpu optimise + OK c -> do return $ CodegenInfo f outty triple cpu hdrs impdirs objs libs flags NONE c (toAlist defuns) tagged @@ -127,8 +120,6 @@ = case codegen of -- Built-in code generators (FIXME: lift these out!) Via "c" -> codegenC ir - Via "java" -> codegenJava ir - Via "llvm" -> codegenLLVM ir -- Any external code generator Via cg -> do let cmd = "idris-" ++ cg ++ " " ++ mainmod ++ " -o " ++ outputFile ir diff --git a/src/IRTS/DumpBC.hs b/src/IRTS/DumpBC.hs --- a/src/IRTS/DumpBC.hs +++ b/src/IRTS/DumpBC.hs @@ -65,7 +65,7 @@ "OP " ++ serializeReg a ++ " " ++ show b ++ " [" ++ interMap c ", " serializeReg ++ "]" NULL r -> "NULL " ++ serializeReg r ERROR s -> "ERROR \"" ++ s ++ "\"" -- FIXME: s may contain quotes - + -- Issue #1596 serialize :: [(Name, [BC])] -> String serialize decls = interMap decls "\n\n" serializeDecl diff --git a/src/IRTS/Java/ASTBuilding.hs b/src/IRTS/Java/ASTBuilding.hs deleted file mode 100644 --- a/src/IRTS/Java/ASTBuilding.hs +++ /dev/null @@ -1,141 +0,0 @@ -module IRTS.Java.ASTBuilding where - -import IRTS.Java.JTypes - -import Language.Java.Syntax hiding (Name) -import qualified Language.Java.Syntax as J - -toClassType :: J.Type -> ClassType -toClassType (RefType (ClassRefType ct)) = ct -toClassType t = error $ "Not a class type: " ++ (show t) - -toRefType :: J.Type -> RefType -toRefType (RefType rt) = rt -toRefType t = error $ "Not a ref type: " ++ (show t) - -class InvocationTarget a where - (~>) :: a -> String -> [Argument] -> Exp - -instance InvocationTarget ClassType where - (~>) (ClassType ts) method args = - MethodInv $ TypeMethodCall - (J.Name $ map fst ts) - (concatMap (map fromActType . snd) ts) - (Ident method) - args - where - fromActType (ActualType refType) = refType - -instance InvocationTarget Exp where - (~>) exp method args = - MethodInv $ PrimaryMethodCall - exp - [] - (Ident method) - args - -instance InvocationTarget J.Type where - (~>) t method args = ((toClassType t) ~> method) args - -class Callable a where - call :: a -> [Argument] -> Exp - -instance Callable String where - call method args = - MethodInv $ MethodCall (J.Name [Ident method]) args - -instance Callable Ident where - call method args = - MethodInv $ MethodCall (J.Name [method]) args - -instance Callable J.Name where - call method args = - MethodInv $ MethodCall method args - -(<>) :: Type -> Exp -> Exp -(<>) = Cast - -localVar :: Int -> Ident -localVar i = Ident $ "loc" ++ show i - -(@!) :: Exp -> Int -> ArrayIndex -(@!) target pos = - ArrayIndex target (Lit $ Int (toInteger pos)) - -(@:=) :: Either ArrayIndex Ident -> Exp -> BlockStmt -(@:=) (Right lhs) rhs = - LocalVars [Final] objectType [VarDecl (VarId lhs) (Just $ InitExp rhs)] -(@:=) (Left lhs) rhs = - BlockStmt . ExpStmt $ Assign (ArrayLhs lhs) EqualA rhs - -(~&&~) :: Exp -> Exp -> Exp -(~&&~) e1 e2 = BinOp e1 CAnd e2 - -(~==~) :: Exp -> Exp -> Exp -(~==~) e1 e2 = BinOp e1 Equal e2 - -addToBlock :: [BlockStmt] -> Exp -> [BlockStmt] -addToBlock blk exp = blk ++ [BlockStmt $ ExpStmt exp] - -jName :: String -> J.Name -jName n = J.Name [Ident n] - -jConst :: String -> Exp -jConst = ExpName . jName - -jReturn :: Exp -> BlockStmt -jReturn = BlockStmt . Return . Just - -jInt :: Int -> Exp -jInt = Lit . Int . toInteger - -jString :: String -> Exp -jString = Lit . String - -simpleMethod :: [Modifier] -> Maybe J.Type -> String -> [FormalParam] -> Block -> Decl -simpleMethod mods t name params body = - MemberDecl $ MethodDecl - mods - [] - t - (Ident $ name) - params - [] - (MethodBody . Just $ body) - -declareFinalObjectArray :: Ident -> Maybe VarInit -> BlockStmt -declareFinalObjectArray name init = - LocalVars [Final] - (array objectType) - [ VarDecl - (VarDeclArray . VarId $ name) - init - ] - -arrayInitExps :: [Exp] -> VarInit -arrayInitExps = InitArray . ArrayInit . map (InitExp) - -extendWithNull :: [Exp] -> Int -> [Exp] -extendWithNull exps additionalZeros = - exps ++ (replicate additionalZeros (Lit $ Null)) - -closure :: Exp -> Exp -closure body = - InstanceCreation - [] - (toClassType idrisClosureType) - [] - (Just $ ClassBody - [ simpleMethod - [Public, Final] (Just objectType) "call" [] - (Block [jReturn body]) - ] - ) - -bigInteger :: String -> Exp -bigInteger s = - InstanceCreation - [] - (toClassType bigIntegerType) - [Lit $ String s] - Nothing diff --git a/src/IRTS/Java/JTypes.hs b/src/IRTS/Java/JTypes.hs deleted file mode 100644 --- a/src/IRTS/Java/JTypes.hs +++ /dev/null @@ -1,331 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -module IRTS.Java.JTypes where - -import Idris.Core.TT -import IRTS.Lang -import Language.Java.Syntax -import qualified Language.Java.Syntax as J - -import qualified Data.Vector.Unboxed as V - ------------------------------------------------------------------------ --- Primitive types - -charType :: J.Type -charType = - PrimType CharT - -byteType :: J.Type -byteType = PrimType ByteT - -shortType :: J.Type -shortType = PrimType ShortT - -integerType :: J.Type -integerType = PrimType IntT - -longType :: J.Type -longType = PrimType LongT - -doubleType :: J.Type -doubleType = PrimType DoubleT - -array :: J.Type -> J.Type -array t = RefType . ArrayType $ t - -addressType :: J.Type -addressType = longType - ------------------------------------------------------------------------ --- Boxed types - -objectType :: J.Type -objectType = - RefType . ClassRefType $ ClassType [(Ident "Object", [])] - -bigIntegerType :: J.Type -bigIntegerType = - RefType . ClassRefType $ ClassType [(Ident "BigInteger", [])] - -stringType :: J.Type -stringType = - RefType . ClassRefType $ ClassType [(Ident "String", [])] - -bufferType :: J.Type -bufferType = - RefType . ClassRefType $ ClassType [(Ident "ByteBuffer", [])] - -threadType :: J.Type -threadType = - RefType . ClassRefType $ ClassType [(Ident "Thread", [])] - -callableType :: J.Type -callableType = - RefType . ClassRefType $ ClassType [(Ident "Callable", [])] - -voidType :: J.Type -voidType = - RefType . ClassRefType $ ClassType [(Ident "Void", [])] - -box :: J.Type -> J.Type -box (PrimType CharT ) = RefType . ClassRefType $ ClassType [(Ident "Character", [])] -box (PrimType ByteT ) = RefType . ClassRefType $ ClassType [(Ident "Byte", [])] -box (PrimType ShortT ) = RefType . ClassRefType $ ClassType [(Ident "Short", [])] -box (PrimType IntT ) = RefType . ClassRefType $ ClassType [(Ident "Integer", [])] -box (PrimType LongT ) = RefType . ClassRefType $ ClassType [(Ident "Long", [])] -box (PrimType DoubleT) = RefType . ClassRefType $ ClassType [(Ident "Double", [])] -box t = t - -isFloating :: J.Type -> Bool -isFloating (PrimType DoubleT) = True -isFloating (PrimType FloatT) = True -isFloating _ = False - -isPrimitive :: J.Type -> Bool -isPrimitive (PrimType _) = True -isPrimitive _ = False - -isArray :: J.Type -> Bool -isArray (RefType (ArrayType _)) = True -isArray _ = False - -isString :: J.Type -> Bool -isString (RefType (ClassRefType (ClassType [(Ident "String", _)]))) = True -isString _ = False - ------------------------------------------------------------------------ --- Idris rts classes - -idrisClosureType :: J.Type -idrisClosureType = - RefType . ClassRefType $ ClassType [(Ident "Closure", [])] - -idrisTailCallClosureType :: J.Type -idrisTailCallClosureType = - RefType . ClassRefType $ ClassType [(Ident "TailCallClosure", [])] - -idrisObjectType :: J.Type -idrisObjectType = - RefType . ClassRefType $ ClassType [(Ident "IdrisObject", [])] - -foreignWrapperType :: J.Type -foreignWrapperType = - RefType . ClassRefType $ ClassType [(Ident "ForeignWrapper", [])] - -primFnType :: J.Type -primFnType = - RefType . ClassRefType $ ClassType [(Ident "PrimFn", [])] - ------------------------------------------------------------------------ --- Java utility classes - -arraysType :: J.Type -arraysType = - RefType . ClassRefType $ ClassType [(Ident "Arrays", [])] - -mathType :: J.Type -mathType = - RefType . ClassRefType $ ClassType [(Ident "Math", [])] - - ------------------------------------------------------------------------ --- Exception types - -exceptionType :: J.Type -exceptionType = - RefType . ClassRefType $ ClassType [(Ident "Exception", [])] - -runtimeExceptionType :: J.Type -runtimeExceptionType = - RefType . ClassRefType $ ClassType [(Ident "RuntimeException", [])] - ------------------------------------------------------------------------ --- Integer types - -nativeTyToJType :: NativeTy -> J.Type -nativeTyToJType IT8 = byteType -nativeTyToJType IT16 = shortType -nativeTyToJType IT32 = integerType -nativeTyToJType IT64 = longType - -intTyToJType :: IntTy -> J.Type -intTyToJType (ITFixed nt) = nativeTyToJType nt -intTyToJType (ITNative) = integerType -intTyToJType (ITBig) = bigIntegerType -intTyToJType (ITChar) = charType -intTyToJType (ITVec nt _) = array $ nativeTyToJType nt - -arithTyToJType :: ArithTy -> J.Type -arithTyToJType (ATInt it) = intTyToJType it -arithTyToJType (ATFloat) = doubleType - ------------------------------------------------------------------------ --- Context variables - -localContextID :: Ident -localContextID = Ident "context" - -localContext :: Exp -localContext = ExpName $ Name [localContextID] - -globalContextID :: Ident -globalContextID = Ident "globalContext" - -globalContext :: Exp -globalContext = ExpName $ Name [globalContextID] - -newContextID :: Ident -newContextID = Ident "new_context" - -newContext :: Exp -newContext = ExpName $ Name [newContextID] - -contextArray :: LVar -> Exp -contextArray (Loc _) = localContext -contextArray (Glob _) = globalContext - -contextParam :: FormalParam -contextParam = FormalParam [Final] (array objectType) False (VarId localContextID) - ------------------------------------------------------------------------ --- Constant types - -constType :: Const -> J.Type -constType (I _) = arithTyToJType (ATInt ITNative) -constType (BI _) = arithTyToJType (ATInt ITBig ) -constType (Fl _) = arithTyToJType (ATFloat ) -constType (Ch _) = arithTyToJType (ATInt ITChar ) -constType (Str _) = stringType -constType (B8 _) = arithTyToJType (ATInt $ ITFixed IT8 ) -constType (B16 _) = arithTyToJType (ATInt $ ITFixed IT16) -constType (B32 _) = arithTyToJType (ATInt $ ITFixed IT32) -constType (B64 _) = arithTyToJType (ATInt $ ITFixed IT64) -constType (B8V v) = arithTyToJType (ATInt . ITVec IT8 $ V.length v) -constType (B16V v) = arithTyToJType (ATInt . ITVec IT16 $ V.length v) -constType (B32V v) = arithTyToJType (ATInt . ITVec IT32 $ V.length v) -constType (B64V v) = arithTyToJType (ATInt . ITVec IT64 $ V.length v) -constType _ = objectType - ------------------------------------------------------------------------ --- Foreign types - -foreignType :: FType -> Maybe J.Type -foreignType (FArith at) = Just $ arithTyToJType at -foreignType (FFunction ) = Just $ callableType -foreignType (FFunctionIO ) = Just $ callableType -foreignType (FString ) = Just $ stringType -foreignType (FUnit ) = Nothing -foreignType (FPtr ) = Just $ objectType -foreignType (FAny ) = Just $ objectType - ------------------------------------------------------------------------ --- Primitive operation analysis - -opName :: PrimFn -> String -opName x - | (LSExt _ to) <- x = "LSExt" ++ (suffixFor to) - | (LZExt _ to) <- x = "LZExt" ++ (suffixFor to) - | (LTrunc _ to) <- x = "LTrunc" ++ (suffixFor to) - | (LFloatInt to) <- x = "LFloatInt" ++ (suffixFor to) - | (LStrInt to) <- x = "LStrInt" ++ (suffixFor to) - | (LChInt to) <- x = "LChInt" ++ (suffixFor to) - | (LPeek to _) <- x = "LPeek" ++ (suffixFor to) - | otherwise = takeWhile ((/=) ' ') $ show x - where - suffixFor (ITFixed nt) = show nt - suffixFor (ITNative) = show IT32 - suffixFor (ITBig) = show ITBig - suffixFor (ITChar) = show ITChar - suffixFor (ITVec nt _) = "ITVec" ++ (show $ nativeTyWidth nt) - -sourceTypes :: PrimFn -> [J.Type] -sourceTypes (LPlus from) = [arithTyToJType from, arithTyToJType from] -sourceTypes (LMinus from) = [arithTyToJType from, arithTyToJType from] -sourceTypes (LTimes from) = [arithTyToJType from, arithTyToJType from] -sourceTypes (LUDiv from) = [intTyToJType from, intTyToJType from] -sourceTypes (LSDiv from) = [arithTyToJType from, arithTyToJType from] -sourceTypes (LURem from) = [intTyToJType from, intTyToJType from] -sourceTypes (LSRem from) = [arithTyToJType from, arithTyToJType from] -sourceTypes (LAnd from) = [intTyToJType from, intTyToJType from] -sourceTypes (LOr from) = [intTyToJType from, intTyToJType from] -sourceTypes (LXOr from) = [intTyToJType from, intTyToJType from] -sourceTypes (LCompl from) = [intTyToJType from] -sourceTypes (LSHL from) = [intTyToJType from, intTyToJType from] -sourceTypes (LLSHR from) = [intTyToJType from, intTyToJType from] -sourceTypes (LASHR from) = [intTyToJType from, intTyToJType from] -sourceTypes (LEq from) = [arithTyToJType from, arithTyToJType from] -sourceTypes (LSLt from) = [arithTyToJType from, arithTyToJType from] -sourceTypes (LSLe from) = [arithTyToJType from, arithTyToJType from] -sourceTypes (LSGt from) = [arithTyToJType from, arithTyToJType from] -sourceTypes (LSGe from) = [arithTyToJType from, arithTyToJType from] -sourceTypes (LLt from) = [intTyToJType from, intTyToJType from] -sourceTypes (LLe from) = [intTyToJType from, intTyToJType from] -sourceTypes (LGt from) = [intTyToJType from, intTyToJType from] -sourceTypes (LGe from) = [intTyToJType from, intTyToJType from] -sourceTypes (LSExt from _) = [intTyToJType from] -sourceTypes (LZExt from _) = [intTyToJType from] -sourceTypes (LTrunc from _) = [intTyToJType from] -sourceTypes (LStrConcat) = repeat stringType -sourceTypes (LStrLt) = [stringType, stringType] -sourceTypes (LStrEq) = [stringType, stringType] -sourceTypes (LStrLen) = [stringType] -sourceTypes (LIntFloat from) = [intTyToJType from] -sourceTypes (LFloatInt _) = [doubleType] -sourceTypes (LIntStr from) = [intTyToJType from] -sourceTypes (LStrInt from) = [stringType] -sourceTypes (LFloatStr) = [doubleType] -sourceTypes (LStrFloat) = [stringType] -sourceTypes (LChInt _) = [charType] -sourceTypes (LIntCh from) = [intTyToJType from] -sourceTypes (LPrintNum) = [objectType] -sourceTypes (LPrintStr) = [stringType] -sourceTypes (LReadStr) = [objectType] -sourceTypes (LFExp) = [doubleType] -sourceTypes (LFLog) = [doubleType] -sourceTypes (LFSin) = [doubleType] -sourceTypes (LFCos) = [doubleType] -sourceTypes (LFTan) = [doubleType] -sourceTypes (LFASin) = [doubleType] -sourceTypes (LFACos) = [doubleType] -sourceTypes (LFATan) = [doubleType] -sourceTypes (LFSqrt) = [doubleType] -sourceTypes (LFFloor) = [doubleType] -sourceTypes (LFCeil) = [doubleType] -sourceTypes (LMkVec nt n) = replicate n (nativeTyToJType nt) -sourceTypes (LIdxVec nt _) = [array $ nativeTyToJType nt, integerType] -sourceTypes (LUpdateVec nt _) = [array $ nativeTyToJType nt, integerType, nativeTyToJType nt] -sourceTypes (LStrHead) = [stringType] -sourceTypes (LStrTail) = [stringType] -sourceTypes (LStrCons) = [charType, stringType] -sourceTypes (LStrIndex) = [stringType, integerType] -sourceTypes (LStrRev) = [stringType] -sourceTypes (LStdIn) = [] -sourceTypes (LStdOut) = [] -sourceTypes (LStdErr) = [] -sourceTypes (LAllocate) = [addressType] -sourceTypes (LAppendBuffer) = - [bufferType, addressType, addressType, addressType, addressType, bufferType] -sourceTypes (LSystemInfo) = [integerType] -sourceTypes (LAppend nt _) = [bufferType, addressType, addressType, intTyToJType nt] -sourceTypes (LPeek _ _) = [bufferType, addressType] -sourceTypes (LFork) = [objectType] -sourceTypes (LPar) = [objectType] -sourceTypes (LVMPtr) = [] -sourceTypes (LNullPtr) = [objectType] -sourceTypes (LNoOp) = repeat objectType - ------------------------------------------------------------------------ --- Endianess markers - -endiannessConstant :: Endianness -> Exp -endiannessConstant c = - ExpName . Name . map Ident $ ["java", "nio", "ByteOrder", endiannessConstant' c] - where - endiannessConstant' BE = "BIG_ENDIAN" - endiannessConstant' LE = "LITTLE_ENDIAN" - endiannessConstant' (IRTS.Lang.Native) = endiannessConstant' BE - -endiannessArguments :: PrimFn -> [Exp] -endiannessArguments (LAppend _ end) = [endiannessConstant end] -endiannessArguments (LPeek _ end) = [endiannessConstant end] -endiannessArguments _ = [] diff --git a/src/IRTS/Java/Mangling.hs b/src/IRTS/Java/Mangling.hs deleted file mode 100644 --- a/src/IRTS/Java/Mangling.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module IRTS.Java.Mangling where - -import Idris.Core.TT -import IRTS.Lang -import IRTS.Simplified - -import Control.Applicative -import Control.Monad -import Control.Monad.Error -import Data.Char - -import Language.Java.Parser -import Language.Java.Pretty -import Language.Java.Syntax hiding (Name) -import qualified Language.Java.Syntax as J - -import System.FilePath -import Debug.Trace - -prefixCallNamespaces :: Ident -> SDecl -> SDecl -prefixCallNamespaces name (SFun fname args i e) = - SFun fname args i (prefixCallNamespacesExp name e) - where - prefixCallNamespacesExp :: Ident -> SExp -> SExp - prefixCallNamespacesExp (Ident name) (SApp tail (NS n ns) args) = - SApp tail (NS n (txt name:ns)) args - prefixCallNamespacesExp name (SLet var e1 e2) = - SLet var (prefixCallNamespacesExp name e1) (prefixCallNamespacesExp name e2) - prefixCallNamespacesExp name (SUpdate var e) = - SUpdate var (prefixCallNamespacesExp name e) - prefixCallNamespacesExp name (SCase up var alts) = - SCase up var (map (prefixCallNamespacesCase name) alts) - prefixCallNamespacesExp name (SChkCase var alts) = - SChkCase var (map (prefixCallNamespacesCase name) alts) - prefixCallNamespacesExp _ exp = exp - - prefixCallNamespacesCase :: Ident -> SAlt -> SAlt - prefixCallNamespacesCase name (SConCase x y n ns e) = - SConCase x y n ns (prefixCallNamespacesExp name e) - prefixCallNamespacesCase name (SConstCase c e) = - SConstCase c (prefixCallNamespacesExp name e) - prefixCallNamespacesCase name (SDefaultCase e) = - SDefaultCase (prefixCallNamespacesExp name e) - -liftParsed :: (Show e, MonadError String m) => Either e a -> m a -liftParsed = either (\ err -> throwError $ "Parser error: " ++ (show err)) - (return) - -mkClassName :: (MonadError String m) => FilePath -> m Ident -mkClassName path = - liftParsed . parser ident . takeBaseName $ takeFileName path - -mangleWithPrefix :: (Applicative m, MonadError String m) => String -> Name -> m Ident -mangleWithPrefix prefix (NS name _) = mangleWithPrefix prefix name -mangleWithPrefix prefix (MN i name) = - (\ (Ident x) -> Ident $ x ++ ('_' : show i)) - <$> mangleWithPrefix prefix (UN name) -mangleWithPrefix prefix (UN name) = - liftParsed - . parser ident - . (prefix ++) - . cleanNonLetter - $ cleanWs False (str name) - where - cleanNonLetter (x:xs) - | x == '#' = "_Hash" ++ cleanNonLetter xs - | x == '@' = "_At" ++ cleanNonLetter xs - | x == '$' = "_Dollar" ++ cleanNonLetter xs - | x == '!' = "_Bang" ++ cleanNonLetter xs - | x == '.' = "_Dot" ++ cleanNonLetter xs - | x == '\'' = "_Prime" ++ cleanNonLetter xs - | x == '*' = "_Times" ++ cleanNonLetter xs - | x == '+' = "_Plus" ++ cleanNonLetter xs - | x == '/' = "_Divide" ++ cleanNonLetter xs - | x == '-' = "_Minus" ++ cleanNonLetter xs - | x == '%' = "_Mod" ++ cleanNonLetter xs - | x == '<' = "_LessThan" ++ cleanNonLetter xs - | x == '=' = "_Equals" ++ cleanNonLetter xs - | x == '>' = "_MoreThan" ++ cleanNonLetter xs - | x == '[' = "_LSBrace" ++ cleanNonLetter xs - | x == ']' = "_RSBrace" ++ cleanNonLetter xs - | x == '(' = "_LBrace" ++ cleanNonLetter xs - | x == ')' = "_RBrace" ++ cleanNonLetter xs - | x == ':' = "_Colon" ++ cleanNonLetter xs - | x == ' ' = "_Space" ++ cleanNonLetter xs - | x == ',' = "_Comma" ++ cleanNonLetter xs - | x == '_' = "__" ++ cleanNonLetter xs - -- 10 digits is the most possible to represent 2^32 (ie all of unicode) - | not (isAlphaNum x) = "_" ++ (padToWith 10 '0' . show $ ord x) ++ cleanNonLetter xs - | otherwise = x:cleanNonLetter xs - cleanNonLetter [] = [] - cleanWs capitalize (x:xs) - | isSpace x = cleanWs True xs - | capitalize = (toUpper x) : (cleanWs False xs) - | otherwise = x : (cleanWs False xs) - cleanWs _ [] = [] - padToWith :: Int -> a -> [a] -> [a] - padToWith n p xs = replicate (length xs - n) p ++ xs -mangleWithPrefix prefix s@(SN _) = mangleWithPrefix prefix (sUN (showCG s)) - -mangle :: (Applicative m, MonadError String m) => Name -> m Ident -mangle = mangleWithPrefix "__IDRCG__" - -mangle' :: Name -> Ident -mangle' = either error id . mangleWithPrefix "__IDRCG__" - -mangleFull :: (Applicative m, MonadError String m) => Name -> m J.Name -mangleFull (NS name (rootns:nss)) = - (\ r n ns -> J.Name (r:(ns ++ [n]))) - <$> mangleWithPrefix "" (UN rootns) - <*> mangle name - <*> mapM (mangle . UN) nss -mangleFull n = J.Name . (:[]) <$> mangle n diff --git a/src/IRTS/Java/Pom.hs b/src/IRTS/Java/Pom.hs deleted file mode 100644 --- a/src/IRTS/Java/Pom.hs +++ /dev/null @@ -1,95 +0,0 @@ -module IRTS.Java.Pom (pomString) where - -import Data.List (unfoldr) -import Text.XML.Light - ------------------------------------------------------------------------ --- String <-> XML processing - -uattr :: String -> String -> Attr -uattr k v = Attr (QName k Nothing Nothing) v - --- from http://stackoverflow.com/a/4978733/283260 -splitOn :: Eq a => a -> [a] -> [[a]] -splitOn chr = unfoldr sep where - sep [] = Nothing - sep l = Just . fmap (drop 1) . break (==chr) $ l - -parseToDep :: String -> Element -parseToDep tuple = - case splitOn ':' tuple of - [g, a, v] -> dependency g a v - _ -> blank_element - -dependency :: String -> String -> String -> Element -dependency g a v = unode "dependency" (groupArtifactVersion g a v) - -groupArtifactVersion :: String -> String -> String -> [Element] -groupArtifactVersion g a v = [ - unode "groupId" g, - unode "artifactId" a, - unode "version" v - ] - -pomString :: String -> String -> [String] -> String -pomString c a d = ppElement $ pom c a d - ------------------------------------------------------------------------ --- The pom template for idris projects - -pom :: String -> String -> [String] -> Element -pom clsName artifactName dependencies = unode "project" ([ - uattr "xmlns" "http://maven.apache.org/POM/4.0.0", - uattr "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance", - uattr "xsi:schemaLocation" "http://maven.apache.org/POM/4.0.0 http://maven.apache.org/maven-v4_0_0.xsd" - ], - [ - unode "modelVersion" "4.0.0", - unode "groupId" "org.idris-lang", - unode "artifactId" artifactName, - unode "packaging" "jar", - unode "version" "1.0", - unode "name" artifactName, - unode "properties" [ - unode "project.build.sourceEncoding" "UTF-8", - unode "skipTest" "true" - ], - unode "dependencies" ( - dependency "org.idris-lang" "idris" "0.9.14" : - map parseToDep dependencies - ), - unode "build" [ - unode "finalName" artifactName, - unode "plugins" [ - unode "plugin" ( - unode "configuration" [ - unode "source" "1.7", - unode "target" "1.7" - ] : groupArtifactVersion "org.apache.maven.plugins" "maven-compiler-plugin" "3.0" - ), - unode "plugin" ( - unode "configuration" ( - unode "skipTests" "${skipTests}" - ) : groupArtifactVersion "org.apache.maven.plugins" "maven-surefile-plugin" "2.14" - ), - unode "plugin" ( - unode "executions" [ - unode "execution" [ - unode "phase" "package", - unode "goals" ( - unode "goal" "shade" - ), - unode "configuration" ( - unode "transformers" ( - unode "transformer" ( - uattr "implementation" "org.apache.maven.plugins.shade.resource.ManifestResourceTransformer", - unode "mainClass" clsName - ) - ) - ) - ] - ] : groupArtifactVersion "org.apache.maven.plugins" "maven-shade-plugin" "2.1" - ) - ] - ] - ]) diff --git a/src/IRTS/Lang.hs b/src/IRTS/Lang.hs --- a/src/IRTS/Lang.hs +++ b/src/IRTS/Lang.hs @@ -52,7 +52,7 @@ | LBitCast ArithTy ArithTy -- Only for values of equal width | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan - | LFSqrt | LFFloor | LFCeil + | LFSqrt | LFFloor | LFCeil | LFNegate -- construction element extraction element insertion | LMkVec NativeTy Int | LIdxVec NativeTy Int | LUpdateVec NativeTy Int diff --git a/src/Idris/AbsSyntax.hs b/src/Idris/AbsSyntax.hs --- a/src/Idris/AbsSyntax.hs +++ b/src/Idris/AbsSyntax.hs @@ -21,7 +21,7 @@ import Control.Monad.State import Control.Monad.Error(throwError) -import Data.List +import Data.List hiding (insert,union) import Data.Char import qualified Data.Text as T import Data.Either @@ -111,9 +111,16 @@ idris_language_extensions = ErrorReflection : idris_language_extensions i } -addTrans :: (Term, Term) -> Idris () -addTrans t = do i <- getIState - putIState $ i { idris_transforms = t : idris_transforms i } +-- Transforms are organised by the function being applied on the lhs of the +-- transform, to make looking up appropriate transforms quicker +addTrans :: Name -> (Term, Term) -> Idris () +addTrans basefn t + = do i <- getIState + let t' = case lookupCtxtExact basefn (idris_transforms i) of + Just def -> (t : def) + Nothing -> [t] + putIState $ i { idris_transforms = addDef basefn t' + (idris_transforms i) } addErrRev :: (Term, Term) -> Idris () addErrRev t = do i <- getIState @@ -279,7 +286,7 @@ addCoercion n = do i <- getIState putIState $ i { idris_coercions = nub $ n : idris_coercions i } -addDocStr :: Name -> Docstring -> [(Name, Docstring)] -> Idris () +addDocStr :: Name -> Docstring DocTerm -> [(Name, Docstring DocTerm)] -> Idris () addDocStr n doc args = do i <- getIState putIState $ i { idris_docstrings = addDef n (doc, args) (idris_docstrings i) } @@ -491,7 +498,7 @@ addDeferred' :: NameType -> [(Name, (Int, Maybe Name, Type, Bool))] -> Idris () addDeferred' nt ns - = do mapM_ (\(n, (i, _, t, _)) -> updateContext (addTyDecl n nt (tidyNames [] t))) ns + = do mapM_ (\(n, (i, _, t, _)) -> updateContext (addTyDecl n nt (tidyNames S.empty t))) ns mapM_ (\(n, _) -> when (not (n `elem` primDefs)) $ addIBC (IBCMetavar n)) ns i <- getIState putIState $ i { idris_metavars = map (\(n, (i, top, _, isTopLevel)) -> (n, (top, i, isTopLevel))) ns ++ @@ -500,11 +507,11 @@ -- 'tidyNames' is to generate user accessible names in case they are -- needed in tactic scripts tidyNames used (Bind (MN i x) b sc) - = let n' = uniqueName (UN x) used in - Bind n' b $ tidyNames (n':used) sc + = let n' = uniqueNameSet (UN x) used in + Bind n' b $ tidyNames (S.insert n' used) sc tidyNames used (Bind n b sc) - = let n' = uniqueName n used in - Bind n' b $ tidyNames (n':used) sc + = let n' = uniqueNameSet n used in + Bind n' b $ tidyNames (S.insert n' used) sc tidyNames used b = b solveDeferred :: Name -> Idris () @@ -601,13 +608,39 @@ setErrContext :: Bool -> Idris () setErrContext t = do i <- getIState let opts = idris_options i - let opt' = opts { opt_errContext = t } - putIState $ i { idris_options = opt' } + let opts' = opts { opt_errContext = t } + putIState $ i { idris_options = opts' } errContext :: Idris Bool errContext = do i <- getIState return (opt_errContext (idris_options i)) +getOptimise :: Idris [Optimisation] +getOptimise = do i <- getIState + return (opt_optimise (idris_options i)) + +setOptimise :: [Optimisation] -> Idris () +setOptimise newopts = do i <- getIState + let opts = idris_options i + let opts' = opts { opt_optimise = newopts } + putIState $ i { idris_options = opts' } + +addOptimise :: Optimisation -> Idris () +addOptimise opt = do opts <- getOptimise + setOptimise (nub (opt : opts)) + +removeOptimise :: Optimisation -> Idris () +removeOptimise opt = do opts <- getOptimise + setOptimise ((nub opts) \\ [opt]) + +-- Set appropriate optimisation set for the given level. We only have +-- one optimisation that is configurable at the moment, however! +setOptLevel :: Int -> Idris () +setOptLevel n | n <= 0 = setOptimise [] +setOptLevel 1 = setOptimise [] +setOptLevel 2 = setOptimise [PETransform] +setOptLevel n | n >= 3 = setOptimise [PETransform] + useREPL :: Idris Bool useREPL = do i <- getIState return (opt_repl (idris_options i)) @@ -701,16 +734,6 @@ targetCPU = do i <- getIState return (opt_cpu (idris_options i)) -setOptLevel :: Word -> Idris () -setOptLevel t = do i <- getIState - let opts = idris_options i - opt' = opts { opt_optLevel = t } - putIState $ i { idris_options = opt' } - -optLevel :: Idris Word -optLevel = do i <- getIState - return (opt_optLevel (idris_options i)) - verbose :: Idris Bool verbose = do i <- getIState return (opt_verbose (idris_options i)) @@ -1033,7 +1056,6 @@ [] -> 0 -- must be locally bound, if it's not an error... pri (PPi _ _ x y) = max 5 (max (pri x) (pri y)) pri (PTrue _ _) = 0 - pri (PFalse _) = 0 pri (PRefl _ _) = 1 pri (PEq _ _ _ l r) = max 1 (max (pri l) (pri r)) pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r)) @@ -1052,21 +1074,36 @@ addStatics :: Name -> Term -> PTerm -> Idris () addStatics n tm ptm = do let (statics, dynamics) = initStatics tm ptm + ist <- getIState + let paramnames + = nub $ case lookupCtxtExact n (idris_fninfo ist) of + Just p -> getNamesFrom 0 (fn_params p) tm ++ + concatMap (getParamNames ist) (map snd statics) + _ -> concatMap (getParamNames ist) (map snd statics) + let stnames = nub $ concatMap freeArgNames (map snd statics) - let dnames = nub $ concatMap freeArgNames (map snd dynamics) + let dnames = (nub $ concatMap freeArgNames (map snd dynamics)) + \\ paramnames -- also get the arguments which are 'uniquely inferrable' from -- statics (see sec 4.2 of "Scrapping Your Inefficient Engine") + -- or parameters to the type of a static let statics' = nub $ map fst statics ++ filter (\x -> not (elem x dnames)) stnames let stpos = staticList statics' tm i <- getIState when (not (null statics)) $ - logLvl 5 $ show n ++ " " ++ show statics' ++ "\n" ++ show dynamics - ++ "\n" ++ show stnames ++ "\n" ++ show dnames + logLvl 3 $ "Statics for " ++ show n ++ " " ++ show tm ++ "\n" + ++ showTmImpls ptm ++ "\n" + ++ show statics ++ "\n" ++ show dynamics + ++ "\n" ++ show paramnames + ++ "\n" ++ show stpos putIState $ i { idris_statics = addDef n stpos (idris_statics i) } addIBC (IBCStatic n) where - initStatics (Bind n (Pi ty _) sc) (PPi p _ _ s) + initStatics (Bind n (Pi ty _) sc) (PPi p n' t s) + | n /= n' = let (static, dynamic) = initStatics sc (PPi p n' t s) in + (static, (n, ty) : dynamic) + initStatics (Bind n (Pi ty _) sc) (PPi p n' _ s) = let (static, dynamic) = initStatics (instantiate (P Bound n ty) sc) s in if pstatic p == Static then ((n, ty) : static, dynamic) else if (not (searchArg p)) @@ -1074,8 +1111,25 @@ else (static, dynamic) initStatics t pt = ([], []) + getParamNames ist tm | (P _ n _ , args) <- unApply tm + = case lookupCtxtExact n (idris_datatypes ist) of + Just ti -> getNamePos 0 (param_pos ti) args + Nothing -> [] + where getNamePos i ps [] = [] + getNamePos i ps (P _ n _ : as) + | i `elem` ps = n : getNamePos (i + 1) ps as + getNamePos i ps (_ : as) = getNamePos (i + 1) ps as + getParamNames ist (Bind t (Pi (P _ n _) _) sc) + = n : getParamNames ist sc + getParamNames ist _ = [] + + getNamesFrom i ps (Bind n (Pi _ _) sc) + | i `elem` ps = n : getNamesFrom (i + 1) ps sc + | otherwise = getNamesFrom (i + 1) ps sc + getNamesFrom i ps sc = [] + freeArgNames (Bind n (Pi ty _) sc) - = nub $ freeArgNames ty + = nub $ freeNames ty ++ freeNames sc -- treat '->' as fn here freeArgNames tm = let (_, args) = unApply tm in concatMap freeNames args @@ -1760,7 +1814,6 @@ match (PRefl _ _) (PRefl _ _) = return [] match (PResolveTC _) (PResolveTC _) = return [] match (PTrue _ _) (PTrue _ _) = return [] - match (PFalse _) (PFalse _) = return [] match (PReturn _) (PReturn _) = return [] match (PPi _ _ t s) (PPi _ _ t' s') = do mt <- match' t t' ms <- match' s s' @@ -1856,8 +1909,9 @@ -- about with shadowing anywhere else). mkUniqueNames :: [Name] -> PTerm -> PTerm -mkUniqueNames env tm = evalState (mkUniq tm) env where - inScope = boundNamesIn tm +mkUniqueNames env tm = evalState (mkUniq tm) (S.fromList env) where + inScope :: S.Set Name + inScope = S.fromList $ boundNamesIn tm mkUniqA arg = do t' <- mkUniq (getTm arg) return (arg { getTm = t' }) @@ -1872,40 +1926,40 @@ -- long as there are no bindings inside tactics though. mkUniqT tac = return tac - mkUniq :: PTerm -> State [Name] PTerm + mkUniq :: PTerm -> State (S.Set Name) PTerm mkUniq (PLam n ty sc) = do env <- get (n', sc') <- - if n `elem` env - then do let n' = uniqueName (initN n (length env)) - (env ++ inScope) + if n `S.member` env + then do let n' = uniqueNameSet (initN n (S.size env)) + (S.union env inScope) return (n', shadow n n' sc) else return (n, sc) - put (n' : env) + put (S.insert n' env) ty' <- mkUniq ty sc'' <- mkUniq sc' return $! PLam n' ty' sc'' mkUniq (PPi p n ty sc) = do env <- get (n', sc') <- - if n `elem` env - then do let n' = uniqueName (initN n (length env)) - (env ++ inScope) + if n `S.member` env + then do let n' = uniqueNameSet (initN n (S.size env)) + (S.union env inScope) return (n', shadow n n' sc) else return (n, sc) - put (n' : env) + put (S.insert n' env) ty' <- mkUniq ty sc'' <- mkUniq sc' return $! PPi p n' ty' sc'' mkUniq (PLet n ty val sc) = do env <- get (n', sc') <- - if n `elem` env - then do let n' = uniqueName (initN n (length env)) - (env ++ inScope) + if n `S.member` env + then do let n' = uniqueNameSet (initN n (S.size env)) + (S.union env inScope) return (n', shadow n n' sc) else return (n, sc) - put (n' : env) + put (S.insert n' env) ty' <- mkUniq ty; val' <- mkUniq val sc'' <- mkUniq sc' return $! PLet n' ty' val' sc'' @@ -1928,11 +1982,11 @@ mkUniq (PDPair fc p (PRef fc' n) t sc) | t /= Placeholder = do env <- get - (n', sc') <- if n `elem` env - then do let n' = uniqueName n (env ++ inScope) + (n', sc') <- if n `S.member` env + then do let n' = uniqueNameSet n (S.union env inScope) return (n', shadow n n' sc) else return (n, sc) - put (n' : env) + put (S.insert n' env) t' <- mkUniq t sc'' <- mkUniq sc' return $! PDPair fc p (PRef fc' n') t' sc'' diff --git a/src/Idris/AbsSyntaxTree.hs b/src/Idris/AbsSyntaxTree.hs --- a/src/Idris/AbsSyntaxTree.hs +++ b/src/Idris/AbsSyntaxTree.hs @@ -29,7 +29,7 @@ import Data.Either import qualified Data.Set as S import Data.Word (Word) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Traversable (Traversable) import Data.Foldable (Foldable) @@ -75,11 +75,11 @@ opt_importdirs :: [FilePath], opt_triple :: String, opt_cpu :: String, - opt_optLevel :: Word, opt_cmdline :: [Opt], -- remember whole command line opt_origerr :: Bool, opt_autoSolve :: Bool, -- ^ automatically apply "solve" tactic in prover - opt_autoImport :: [FilePath] -- ^ e.g. Builtins+Prelude + opt_autoImport :: [FilePath], -- ^ e.g. Builtins+Prelude + opt_optimise :: [Optimisation] } deriving (Show, Eq) @@ -99,17 +99,22 @@ , opt_importdirs = [] , opt_triple = "" , opt_cpu = "" - , opt_optLevel = 2 , opt_cmdline = [] , opt_origerr = False , opt_autoSolve = True , opt_autoImport = [] + , opt_optimise = defaultOptimise } data PPOption = PPOption { ppopt_impl :: Bool -- ^^ whether to show implicits } deriving (Show) +data Optimisation = PETransform -- partial eval and associated transforms + deriving (Show, Eq) + +defaultOptimise = [PETransform] + -- | Pretty printing options with default verbosity. defaultPPOption :: PPOption defaultPPOption = PPOption { ppopt_impl = False } @@ -158,9 +163,10 @@ idris_flags :: Ctxt [FnOpt], idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos idris_calledgraph :: Ctxt [Name], - idris_docstrings :: Ctxt (Docstring, [(Name, Docstring)]), + idris_docstrings :: Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]), idris_tyinfodata :: Ctxt TIData, idris_fninfo :: Ctxt FnInfo, + idris_transforms :: Ctxt [(Term, Term)], idris_totcheck :: [(FC, Name)], -- names to check totality on idris_defertotcheck :: [(FC, Name)], -- names to check at the end idris_totcheckfail :: [(FC, String)], @@ -170,7 +176,6 @@ -- ^ Full application LHS on source line idris_metavars :: [(Name, (Maybe Name, Int, Bool))], -- ^ The currently defined but not proven metavariables idris_coercions :: [Name], - idris_transforms :: [(Term, Term)], idris_errRev :: [(Term, Term)], syntax_rules :: [Syntax], syntax_keywords :: [String], @@ -238,7 +243,7 @@ primDefs = [sUN "unsafePerformPrimIO", sUN "mkLazyForeignPrim", sUN "mkForeignPrim", - sUN "FalseElim"] + sUN "void"] -- information that needs writing for the current module's .ibc file data IBCWrite = IBCFix FixDecl @@ -264,7 +269,7 @@ | IBCTotal Name Totality | IBCFlags Name [FnOpt] | IBCFnInfo Name FnInfo - | IBCTrans (Term, Term) + | IBCTrans Name (Term, Term) | IBCErrRev (Term, Term) | IBCCG Name | IBCDoc Name @@ -284,8 +289,8 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext - emptyContext emptyContext emptyContext - [] [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] [] + emptyContext emptyContext emptyContext emptyContext + [] [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] [] (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty AutomaticWidth S.empty Nothing Nothing [] @@ -363,7 +368,12 @@ | CallsWho Name | MakeDoc String -- IdrisDoc | Warranty + | PrintDef Name + | PPrint OutputFmt Int PTerm + | TransformInfo Name +data OutputFmt = HTMLOutput | LaTeXOutput + data Opt = Filename String | Quiet | NoBanner @@ -389,6 +399,7 @@ | ErrContext | ShowImpl | Verbose + | Port String -- REPL TCP port | IBCSubDir String | ImportDir String | PkgBuild String @@ -410,7 +421,9 @@ | EvalExpr String | TargetTriple String | TargetCPU String - | OptLevel Word + | OptLevel Int + | AddOpt Optimisation + | RemoveOpt Optimisation | Client String | ShowOrigErr | AutoWidth -- ^ Automatically adjust terminal width @@ -479,7 +492,7 @@ impl = Imp [] Dynamic False expl = Exp [] Dynamic False expl_param = Exp [] Dynamic True -constraint = Constraint [] Dynamic +constraint = Constraint [] Static tacimpl t = TacImp [] Dynamic t data FnOpt = Inlinable -- always evaluate when simplifying @@ -530,19 +543,19 @@ -- datatypes and typeclasses. data PDecl' t = PFix FC Fixity [String] -- ^ Fixity declaration - | PTy Docstring [(Name, Docstring)] SyntaxInfo FC FnOpts Name t -- ^ Type declaration - | PPostulate Docstring SyntaxInfo FC FnOpts Name t -- ^ Postulate + | PTy (Docstring (Either Err PTerm)) [(Name, Docstring (Either Err PTerm))] SyntaxInfo FC FnOpts Name t -- ^ Type declaration + | PPostulate (Docstring (Either Err PTerm)) SyntaxInfo FC FnOpts Name t -- ^ Postulate | PClauses FC FnOpts Name [PClause' t] -- ^ Pattern clause | PCAF FC Name t -- ^ Top level constant - | PData Docstring [(Name, Docstring)] SyntaxInfo FC DataOpts (PData' t) -- ^ Data declaration. + | PData (Docstring (Either Err PTerm)) [(Name, Docstring (Either Err PTerm))] SyntaxInfo FC DataOpts (PData' t) -- ^ Data declaration. | PParams FC [(Name, t)] [PDecl' t] -- ^ Params block | PNamespace String [PDecl' t] -- ^ New namespace - | PRecord Docstring SyntaxInfo FC Name t DataOpts Docstring Name t -- ^ Record declaration - | PClass Docstring SyntaxInfo FC + | PRecord (Docstring (Either Err PTerm)) SyntaxInfo FC Name t DataOpts (Docstring (Either Err PTerm)) Name t -- ^ Record declaration + | PClass (Docstring (Either Err PTerm)) SyntaxInfo FC [t] -- constraints Name [(Name, t)] -- parameters - [(Name, Docstring)] -- parameter docstrings + [(Name, Docstring (Either Err PTerm))] -- parameter docstrings [PDecl' t] -- declarations -- ^ Type class: arguments are documentation, syntax info, source location, constraints, -- class name, parameters, method declarations @@ -593,7 +606,7 @@ -- | Data declaration data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype d_tcon :: t, -- ^ Type constructor - d_cons :: [(Docstring, [(Name, Docstring)], Name, t, FC, [Name])] -- ^ Constructors + d_cons :: [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, t, FC, [Name])] -- ^ Constructors } -- ^ Data declaration | PLaterdecl { d_name :: Name, d_tcon :: t } @@ -692,37 +705,36 @@ data PunInfo = IsType | IsTerm | TypeOrTerm deriving (Eq, Show) -- | High level language terms -data PTerm = PQuote Raw - | PRef FC Name +data PTerm = PQuote Raw -- ^ Inclusion of a core term into the high-level language + | PRef FC Name -- ^ A reference to a variable | PInferRef FC Name -- ^ A name to be defined later - | PPatvar FC Name - | PLam Name PTerm PTerm + | PPatvar FC Name -- ^ A pattern variable + | PLam Name PTerm PTerm -- ^ A lambda abstraction | PPi Plicity Name PTerm PTerm -- ^ (n : t1) -> t2 - | PLet Name PTerm PTerm PTerm + | PLet Name PTerm PTerm PTerm -- ^ A let binding | PTyped PTerm PTerm -- ^ Term with explicit type | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x | PAppBind FC PTerm [PArg] -- ^ implicitly bound application | PMatchApp FC Name -- ^ Make an application by type matching - | PCase FC PTerm [(PTerm, PTerm)] + | PCase FC PTerm [(PTerm, PTerm)] -- ^ A case expression. Args are source location, scrutinee, and a list of pattern/RHS pairs | PTrue FC PunInfo -- ^ Unit type..? - | PFalse FC -- ^ _|_ - | PRefl FC PTerm - | PResolveTC FC + | PRefl FC PTerm -- ^ The canonical proof of the equality type + | PResolveTC FC -- ^ Solve this dictionary by type class resolution | PEq FC PTerm PTerm PTerm PTerm -- ^ Heterogeneous equality type: A = B - | PRewrite FC PTerm PTerm (Maybe PTerm) - | PPair FC PunInfo PTerm PTerm - | PDPair FC PunInfo PTerm PTerm PTerm - | PAlternative Bool [PTerm] -- True if only one may work + | PRewrite FC PTerm PTerm (Maybe PTerm) -- ^ "rewrite" syntax, with optional result type + | PPair FC PunInfo PTerm PTerm -- ^ A pair (a, b) and whether it's a product type or a pair (solved by elaboration) + | PDPair FC PunInfo PTerm PTerm PTerm -- ^ A dependent pair (tm : a ** b) and whether it's a sigma type or a pair that inhabits one (solved by elaboration) + | PAlternative Bool [PTerm] -- ^ True if only one may work. (| A, B, C|) | PHidden PTerm -- ^ Irrelevant or hidden pattern | PType -- ^ 'Type' type | PUniverse Universe -- ^ Some universe - | PGoal FC PTerm Name PTerm + | PGoal FC PTerm Name PTerm -- ^ quoteGoal, used for %reflection functions | PConstant Const -- ^ Builtin types - | Placeholder - | PDoBlock [PDo] - | PIdiom FC PTerm + | Placeholder -- ^ Underscore + | PDoBlock [PDo] -- ^ Do notation + | PIdiom FC PTerm -- ^ Idiom brackets | PReturn FC - | PMetavar Name + | PMetavar Name -- ^ A metavariable, ?name | PProof [PTactic] -- ^ Proof script | PTactics [PTactic] -- ^ As PProof, but no auto solving | PElabError Err -- ^ Error to report on elaboration @@ -968,6 +980,11 @@ data Syntax = Rule [SSymbol] PTerm SynContext deriving Show + +syntaxNames :: Syntax -> [Name] +syntaxNames (Rule syms _ _) = mapMaybe ename syms + where ename (Keyword n) = Just n + ename _ = Nothing {-! deriving instance Binary Syntax deriving instance NFData Syntax @@ -979,6 +996,8 @@ | Expr Name | SimpleExpr Name deriving Show + + {-! deriving instance Binary SSymbol deriving instance NFData SSymbol @@ -1014,14 +1033,14 @@ maxline :: Maybe Int, mut_nesting :: Int, dsl_info :: DSL, - syn_in_quasiquote :: Bool } + syn_in_quasiquote :: Int } deriving Show {-! deriving instance NFData SyntaxInfo deriving instance Binary SyntaxInfo !-} -defaultSyntax = Syn [] [] [] [] id False False Nothing 0 initDSL False +defaultSyntax = Syn [] [] [] [] id False False Nothing 0 initDSL 0 expandNS :: SyntaxInfo -> Name -> Name expandNS syn n@(NS _ _) = n @@ -1059,51 +1078,26 @@ --- Handy primitives: Unit, False, Pair, MkPair, =, mkForeign, Elim type class +-- Handy primitives: Unit, False, Pair, MkPair, =, mkForeign -primNames = [unitTy, unitCon, - falseTy, pairTy, pairCon, - eqTy, eqCon, inferTy, inferCon] +primNames = [eqTy, eqCon, inferTy, inferCon] -unitDoc = parseDocstring . T.pack $ "The canonical single-element type, also known as the trivially true proposition." -unitTy = sMN 0 "__Unit" -unitCon = sMN 0 "__II" -unitDecl = PDatadecl unitTy PType - [(parseDocstring . T.pack $ "The trivial constructor for `()`. ", [], unitCon, PRef bi unitTy, bi, [])] -unitOpts = [DefaultEliminator] +unitTy = sUN "Unit" +unitCon = sUN "MkUnit" -falseDoc = parseDocstring . T.pack $ +falseDoc = fmap (const $ Msg "") . parseDocstring . T.pack $ "The empty type, also known as the trivially false proposition." ++ "\n\n" ++ - "Use `FalseElim` or `absurd` to prove anything if you have a variable " ++ - "of type `_|_` in scope." -falseTy = sMN 0 "__False" -falseDecl = PDatadecl falseTy PType [] -falseOpts = [] + "Use `void` or `absurd` to prove anything if you have a variable " ++ + "of type `Void` in scope." +falseTy = sUN "Void" -pairDoc = parseDocstring . T.pack $ "The non-dependent pair type, also known as conjunction." -pairTy = sMN 0 "__Pair" -pairCon = sMN 0 "__MkPair" -pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType) - [(pairConDoc, pairConParamDoc, - pairCon, PPi impl (n "A") PType ( - PPi impl (n "B") PType ( - PPi expl (n "a") (PRef bi (n "A")) ( - PPi expl (n "b") (PRef bi (n "B")) - (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")), - pexp (PRef bi (n "B"))])))), bi, [])] - where n a = sMN 0 a - pairConDoc = parseDocstring . T.pack $ "A pair of elements" - pairConParamDoc = [(n "a", parseDocstring . T.pack $ "the left element of the pair"), - (n "b", parseDocstring . T.pack $ "the right element of the pair")] -pairOpts = [] -pairParamDoc = [(n "A", parseDocstring . T.pack $ "the type of the left elements in the pair"), - (n "B", parseDocstring . T.pack $ "the type of the left elements in the pair")] - where n a = sMN 0 a +pairTy = sUN "Pair" +pairCon = sUN "MkPair" eqTy = sUN "=" -eqCon = sUN "refl" -eqDoc = parseDocstring . T.pack $ +eqCon = sUN "Refl" +eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $ "The propositional equality type. A proof that `x` = `y`." ++ "\n\n" ++ "To use such a proof, pattern-match on it, and the two equal things will " ++ @@ -1126,29 +1120,22 @@ pexp (PRef bi (n "x")), pexp (PRef bi (n "x"))])), bi, [])] where n a = sUN a - reflDoc = parseDocstring . T.pack $ + reflDoc = annotCode (const (Left $ Msg "")) . parseDocstring . T.pack $ "A proof that `x` in fact equals `x`. To construct this, you must have already " ++ "shown that both sides are in fact equal." - reflParamDoc = [(n "A", parseDocstring . T.pack $ "the type at which the equality is proven"), - (n "x", parseDocstring . T.pack $ "the element shown to be equal to itself.")] + reflParamDoc = [(n "A", annotCode (const (Left $ Msg "")) . parseDocstring . T.pack $ "the type at which the equality is proven"), + (n "x", annotCode (const (Left $ Msg "")) . parseDocstring . T.pack $ "the element shown to be equal to itself.")] -eqParamDoc = [(n "A", parseDocstring . T.pack $ "the type of the left side of the equality"), - (n "B", parseDocstring . T.pack $ "the type of the right side of the equality") +eqParamDoc = [(n "A", annotCode (const (Left $ Msg "")) . parseDocstring . T.pack $ "the type of the left side of the equality"), + (n "B", annotCode (const (Left $ Msg "")) . parseDocstring . T.pack $ "the type of the right side of the equality") ] where n a = sUN a eqOpts = [] -elimName = sUN "__Elim" -elimMethElimTy = sUN "__elimTy" -elimMethElim = sUN "elim" -elimDecl = PClass (parseDocstring . T.pack $ "Type class for eliminators") defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)] [] - [PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElimTy PType, - PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)] - -- Defined in builtins.idr sigmaTy = sUN "Sigma" -existsCon = sUN "Sg_intro" +existsCon = sUN "MkSigma" piBind :: [(Name, PTerm)] -> PTerm -> PTerm piBind = piBindp expl @@ -1206,6 +1193,8 @@ colour UnderlineText = IdrisColour Nothing True True False False colour ItalicText = IdrisColour Nothing True False False True consoleDecorate ist (AnnTerm _ _) = id +consoleDecorate ist (AnnSearchResult _) = id +consoleDecorate ist (AnnErr _) = id isPostulateName :: Name -> IState -> Bool isPostulateName n ist = S.member n (idris_postulates ist) @@ -1244,10 +1233,9 @@ text "\\" <> bindingOf n False <+> text "=>" <$> prettySe 10 ((n, False):bnd) sc prettySe p bnd (PLet n ty v sc) = - bracket p 2 $ - kwd "let" <+> bindingOf n False <+> text "=" - prettySe 10 bnd v <+> kwd "in" - prettySe 10 ((n, False):bnd) sc + bracket p 2 . group . align $ + kwd "let" <+> (group . align . hang 2 $ bindingOf n False <+> text "=" <$> prettySe 10 bnd v) + kwd "in" <+> (group . align . hang 2 $ prettySe 10 ((n, False):bnd) sc) prettySe p bnd (PPi (Exp l s _) n ty sc) | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs = bracket p 2 . group $ @@ -1334,15 +1322,23 @@ sc (l, r) = nest nestingSize $ prettySe 10 bnd l <+> text "=>" <+> prettySe 10 bnd r prettySe p bnd (PHidden tm) = text "." <> prettySe 0 bnd tm - prettySe p bnd (PRefl _ _) = annName eqCon $ text "refl" + prettySe p bnd (PRefl _ _) = annName eqCon $ text "Refl" prettySe p bnd (PResolveTC _) = text "resolvetc" prettySe p bnd (PTrue _ IsType) = annName unitTy $ text "()" prettySe p bnd (PTrue _ IsTerm) = annName unitCon $ text "()" prettySe p bnd (PTrue _ TypeOrTerm) = text "()" - prettySe p bnd (PFalse _) = annName falseTy $ text "_|_" - prettySe p bnd (PEq _ _ _ l r) = - bracket p 2 . align . group $ - prettySe 10 bnd l <+> eq <$> group (prettySe 10 bnd r) + prettySe p bnd (PEq _ lt rt l r) + | ppopt_impl ppo = + bracket p 1 $ + enclose lparen rparen eq <+> + align (group (vsep (map (prettyArgS bnd) + [PImp 0 False [] (sUN "A") lt, + PImp 0 False [] (sUN "B") rt, + PExp 0 [] (sUN "x") l, + PExp 0 [] (sUN "y") r]))) + | otherwise = + bracket p 2 . align . group $ + prettySe 10 bnd l <+> eq <$> group (prettySe 10 bnd r) where eq = annName eqTy (text "=") prettySe p bnd (PRewrite _ l r _) = bracket p 2 $ @@ -1480,11 +1476,6 @@ getFixity :: String -> Maybe Fixity getFixity = flip M.lookup fixities -prettyDocumentedIst :: IState -> (Name, PTerm, Maybe Docstring) -> Doc OutputAnnotation -prettyDocumentedIst ist (name, ty, docs) = - prettyName True True [] name <+> colon <+> align (prettyIst ist ty) <$> - fromMaybe empty (fmap (\d -> renderDocstring d <> line) docs) - -- | Pretty-printer helper for the binding site of a name bindingOf :: Name -- ^^ the bound name -> Bool -- ^^ whether the name is implicit @@ -1505,7 +1496,6 @@ baseName (UN n) = T.unpack n baseName (NS n ns) = baseName n baseName (MN i s) = T.unpack s - baseName n | n == falseTy = "_|_" baseName other = show other nameSpace = case n of (NS n' ns) -> if showNS then (concatMap (++ ".") . map T.unpack . reverse) ns else "" @@ -1635,7 +1625,6 @@ size (PAppBind fc name args) = 1 + size args size (PCase fc trm bdy) = 1 + size trm + size bdy size (PTrue fc _) = 1 - size (PFalse fc) = 1 size (PRefl fc _) = 1 size (PResolveTC fc) = 1 size (PEq fc _ _ left right) = 1 + size left + size right diff --git a/src/Idris/Apropos.hs b/src/Idris/Apropos.hs --- a/src/Idris/Apropos.hs +++ b/src/Idris/Apropos.hs @@ -38,10 +38,9 @@ isApropos str (NS n' ns) = isApropos str n' || any (textIn str) ns -- Handle special names from stdlib isApropos str n | (n == unitTy || n == unitCon) && str == T.pack "()" = True - | n == falseTy && str == T.pack "_|_" = True | (n == pairTy || n == pairCon) && str == T.pack "," = True | n == eqTy && str == T.pack "=" = True - | n == eqCon && (T.toLower str) == T.pack "refl" = True + | n == eqCon && (T.toLower str) == T.pack "Refl" = True | (n == sigmaTy || n == existsCon) && str == T.pack "**" = True isApropos _ _ = False -- we don't care about case blocks, MNs, etc @@ -71,7 +70,7 @@ instance Apropos Const where isApropos str c = textIn str (T.pack (show c)) -instance Apropos Docstring where +instance Apropos (Docstring a) where isApropos str d = containsText str d instance (Apropos a, Apropos b) => Apropos (a, b) where diff --git a/src/Idris/Chaser.hs b/src/Idris/Chaser.hs --- a/src/Idris/Chaser.hs +++ b/src/Idris/Chaser.hs @@ -70,7 +70,7 @@ buildTree :: [FilePath] -> -- already guaranteed built FilePath -> Idris [ModuleTree] -buildTree built fp = btree [] fp +buildTree built fp = btree [] fp -- = idrisCatch (btree [] fp) -- (\e -> do now <- runIO $ getCurrentTime -- iputStrLn (show e) @@ -114,6 +114,10 @@ -- FIXME: It's also not up to date if anything it imports has -- been modified since its own ibc has. + -- + -- Issue #1592 on the issue tracker. + -- + -- https://github.com/idris-lang/Idris-dev/issues/1592 checkIBCUpToDate fn (LIDR src) = older fn src checkIBCUpToDate fn (IDR src) = older fn src diff --git a/src/Idris/CmdOptions.hs b/src/Idris/CmdOptions.hs --- a/src/Idris/CmdOptions.hs +++ b/src/Idris/CmdOptions.hs @@ -64,7 +64,7 @@ parser :: Parser [Opt] parser = runA $ proc () -> do flags <- asA parseFlags -< () - files <- asA (many $ argument ((fmap . fmap) Filename str) (metavar "FILES")) -< () + files <- asA (many $ argument (fmap Filename str) (metavar "FILES")) -< () A parseVersion >>> A helper -< (flags ++ files) parseFlags :: Parser [Opt] @@ -80,7 +80,7 @@ <|> flag' NoBuiltins (long "nobuiltins") <|> flag' NoREPL (long "check" <> help "Typecheck only, don't start the REPL") <|> (Output <$> strOption (short 'o' <> long "output" <> metavar "FILE" <> help "Specify output file")) - <|> flag' TypeCase (long "typecase") +-- <|> flag' TypeCase (long "typecase") <|> flag' TypeInType (long "typeintype") <|> flag' DefaultTotal (long "total" <> help "Require functions to be total by default") <|> flag' DefaultPartial (long "partial") @@ -96,6 +96,7 @@ <|> (ImportDir <$> strOption (short 'i' <> long "idrispath" <> help "Add directory to the list of import paths")) <|> flag' WarnOnly (long "warn") <|> (Pkg <$> strOption (short 'p' <> long "package")) + <|> (Port <$> strOption (long "port" <> metavar "PORT" <> help "REPL TCP port")) -- Package commands <|> (PkgBuild <$> strOption (long "build" <> metavar "IPKG" <> help "Build package")) <|> (PkgInstall <$> strOption (long "install" <> metavar "IPKG" <> help "Install package")) @@ -115,11 +116,13 @@ <|> (EvalExpr <$> strOption (long "eval" <> short 'e' <> metavar "EXPR" <> help "Evaluate an expression without loading the REPL")) <|> flag' (InterpretScript "Main.main") (long "execute" <> help "Execute as idris") <|> (InterpretScript <$> strOption (long "exec" <> metavar "EXPR" <> help "Execute as idris")) - <|> ((\s -> Extension $ getExt s) <$> strOption (long "extension" <> short 'X' <> metavar "EXT" <> help "Turn on langage extension (TypeProviders or ErrorReflection)")) + <|> ((\s -> Extension $ getExt s) <$> strOption (long "extension" <> short 'X' <> metavar "EXT" <> help "Turn on language extension (TypeProviders or ErrorReflection)")) <|> flag' (OptLevel 3) (long "O3") <|> flag' (OptLevel 2) (long "O2") <|> flag' (OptLevel 1) (long "O1") <|> flag' (OptLevel 0) (long "O0") + <|> flag' (AddOpt PETransform) (long "partial-eval") + <|> flag' (RemoveOpt PETransform) (long "no-partial-eval") <|> (OptLevel <$> option auto (short 'O' <> long "level")) <|> (TargetTriple <$> strOption (long "target" <> metavar "TRIPLE" <> help "Select target triple (for llvm codegen)")) <|> (TargetCPU <$> strOption (long "cpu" <> metavar "CPU" <> help "Select target CPU e.g. corei7 or cortex-m3 (for LLVM codegen)")) diff --git a/src/Idris/Core/Binary.hs b/src/Idris/Core/Binary.hs --- a/src/Idris/Core/Binary.hs +++ b/src/Idris/Core/Binary.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-} + {-| Binary instances for the core datatypes -} module Idris.Core.Binary where @@ -7,6 +9,169 @@ import Idris.Core.TT +instance Binary ErrorReportPart where + put (TextPart msg) = do putWord8 0 ; put msg + put (NamePart n) = do putWord8 1 ; put n + put (TermPart t) = do putWord8 2 ; put t + put (SubReport ps) = do putWord8 3 ; put ps + + get = do i <- getWord8 + case i of + 0 -> fmap TextPart get + 1 -> fmap NamePart get + 2 -> fmap TermPart get + 3 -> fmap SubReport get + _ -> error "Corrupted binary data for ErrorReportPart" + +instance Binary a => Binary (Err' a) where + put (Msg str) = do putWord8 0 + put str + put (InternalMsg str) = do putWord8 1 + put str + put (CantUnify x y z e ctxt i) = do putWord8 2 + put x + put y + put z + put e + put ctxt + put i + put (InfiniteUnify n t ctxt) = do putWord8 3 + put n + put t + put ctxt + put (CantConvert x y ctxt) = do putWord8 4 + put x + put y + put ctxt + put (CantSolveGoal x ctxt) = do putWord8 5 + put x + put ctxt + put (UnifyScope n1 n2 x ctxt) = do putWord8 6 + put n1 + put n2 + put x + put ctxt + put (CantInferType str) = do putWord8 7 + put str + put (NonFunctionType t1 t2) = do putWord8 8 + put t1 + put t2 + put (NotEquality t1 t2) = do putWord8 9 + put t1 + put t2 + put (TooManyArguments n) = do putWord8 10 + put n + put (CantIntroduce t) = do putWord8 11 + put t + put (NoSuchVariable n) = do putWord8 12 + put n + put (NoTypeDecl n) = do putWord8 13 + put n + put (NotInjective x y z) = do putWord8 14 + put x + put y + put z + put (CantResolve t) = do putWord8 15 + put t + put (CantResolveAlts ns) = do putWord8 16 + put ns + put (IncompleteTerm t) = do putWord8 17 + put t + put UniverseError = putWord8 18 + put (UniqueError u n) = do putWord8 19 + put u + put n + put (UniqueKindError u n) = do putWord8 20 + put u + put n + put ProgramLineComment = putWord8 21 + put (Inaccessible n) = do putWord8 22 + put n + put (NonCollapsiblePostulate n) = do putWord8 23 + put n + put (AlreadyDefined n) = do putWord8 24 + put n + put (ProofSearchFail e) = do putWord8 25 + put e + put (NoRewriting t) = do putWord8 26 + put t + put (At fc e) = do putWord8 27 + put fc + put e + put (Elaborating str n e) = do putWord8 28 + put str + put n + put e + put (ElaboratingArg n1 n2 ns e) = do putWord8 29 + put n1 + put n2 + put ns + put e + put (ProviderError str) = do putWord8 30 + put str + put (LoadingFailed str e) = do putWord8 31 + put str + put e + put (ReflectionError parts e) = do putWord8 32 + put parts + put e + put (ReflectionFailed str e) = do putWord8 33 + put str + put e + + get = do i <- getWord8 + case i of + 0 -> fmap Msg get + 1 -> fmap InternalMsg get + 2 -> do x <- get ; y <- get ; z <- get ; e <- get ; ctxt <- get ; i <- get + return $ CantUnify x y z e ctxt i + 3 -> do x <- get ; y <- get ; z <- get + return $ InfiniteUnify x y z + 4 -> do x <- get ; y <- get ; z <- get + return $ CantConvert x y z + 5 -> do x <- get ; y <- get + return $ CantSolveGoal x y + 6 -> do w <- get ; x <- get ; y <- get ; z <- get + return $ UnifyScope w x y z + 7 -> fmap CantInferType get + 8 -> do x <- get ; y <- get + return $ NonFunctionType x y + 9 -> do x <- get ; y <- get + return $ NotEquality x y + 10 -> fmap TooManyArguments get + 11 -> fmap CantIntroduce get + 12 -> fmap NoSuchVariable get + 13 -> fmap NoTypeDecl get + 14 -> do x <- get ; y <- get ; z <- get + return $ NotInjective x y z + 15 -> fmap CantResolve get + 16 -> fmap CantResolveAlts get + 17 -> fmap IncompleteTerm get + 18 -> return UniverseError + 19 -> do x <- get ; y <- get + return $ UniqueError x y + 20 -> do x <- get ; y <- get + return $ UniqueKindError x y + 21 -> return ProgramLineComment + 22 -> fmap Inaccessible get + 23 -> fmap NonCollapsiblePostulate get + 24 -> fmap AlreadyDefined get + 25 -> fmap ProofSearchFail get + 26 -> fmap NoRewriting get + 27 -> do x <- get ; y <- get + return $ At x y + 28 -> do x <- get ; y <- get ; z <- get + return $ Elaborating x y z + 29 -> do w <- get ; x <- get ; y <- get ; z <- get + return $ ElaboratingArg w x y z + 30 -> fmap ProviderError get + 31 -> do x <- get ; y <- get + return $ LoadingFailed x y + 32 -> do x <- get ; y <- get + return $ ReflectionError x y + 33 -> do x <- get ; y <- get + return $ ReflectionFailed x y + _ -> error "Corrupted binary data for Err'" ----- Generated by 'derive' instance Binary FC where @@ -145,6 +310,7 @@ B64V x1 -> putWord8 24 >> put x1 BufferType -> putWord8 25 ManagedPtrType -> putWord8 26 + VoidType -> putWord8 27 get = do i <- getWord8 case i of @@ -187,7 +353,7 @@ 24 -> fmap B64V get 25 -> return BufferType 26 -> return ManagedPtrType - + 27 -> return VoidType _ -> error "Corrupted binary data for Const" @@ -208,6 +374,8 @@ put x1 RForce x1 -> do putWord8 5 put x1 + RUType x1 -> do putWord8 6 + put x1 get = do i <- getWord8 case i of @@ -225,6 +393,8 @@ return (RConstant x1) 5 -> do x1 <- get return (RForce x1) + 6 -> do x1 <- get + return (RUType x1) _ -> error "Corrupted binary data for Raw" diff --git a/src/Idris/Core/Constraints.hs b/src/Idris/Core/Constraints.hs --- a/src/Idris/Core/Constraints.hs +++ b/src/Idris/Core/Constraints.hs @@ -11,7 +11,7 @@ import Control.Monad.State import Data.List import Data.Maybe -import qualified Data.Map as M +import qualified Data.Map.Strict as M import Debug.Trace @@ -20,7 +20,8 @@ ucheck cs = acyclic rels (map fst (M.toList rels)) where lhs (ULT l _) = l lhs (ULE l _) = l - rels = mkRels cs M.empty + cs' = nub cs + rels = mkRels cs' M.empty type Relations = M.Map UExp [(UConstraint, FC)] @@ -44,13 +45,13 @@ checkCycle :: FC -> Relations -> [(UExp, FC)] -> Int -> [UExp] -> TC () checkCycle fc r path inc [] = return () checkCycle fc r path inc (c : cs) - = do check fc path inc c + = do check fc r path inc c -- Remove c from r since we know there's no cycles now let r' = M.insert c [] r checkCycle fc r' path inc cs - check fc path inc (UVar x) | x < 0 = return () - check fc path inc cv + check fc r path inc (UVar x) | x < 0 = return () + check fc r path inc cv | inc > 0 && cv `elem` map fst path = Error $ At fc UniverseError -- FIXME: Make informative @@ -59,10 +60,11 @@ -- fine, because they must all be equal, so stop. | inc == 0 && cv `elem` map fst path = return () - | otherwise = case M.lookup cv r of - Nothing -> return () - Just cs -> mapM_ (next ((cv, fc):path) inc) cs + | otherwise + = case M.lookup cv r of + Nothing -> return () + Just cs -> mapM_ (next r ((cv, fc):path) inc) cs - next path inc (ULT l r, fc) = check fc path (inc + 1) r - next path inc (ULE l r, fc) = check fc path inc r + next r path inc (ULT l x, fc) = check fc r path (inc + 1) x + next r path inc (ULE l x, fc) = check fc r path inc x diff --git a/src/Idris/Core/Elaborate.hs b/src/Idris/Core/Elaborate.hs --- a/src/Idris/Core/Elaborate.hs +++ b/src/Idris/Core/Elaborate.hs @@ -373,6 +373,7 @@ -- | Turn the current hole into a pattern variable with the provided name, made unique if MN patvar :: Name -> Elab' aux () +patvar n@(SN _) = do apply (Var n) []; solve patvar n = do env <- get_env hs <- get_holes if (n `elem` map fst env) then do apply (Var n) []; solve @@ -380,6 +381,7 @@ UN _ -> return $! n MN _ _ -> unique_hole n NS _ _ -> return $! n + x -> return $! n processTactic' (PatVar n') patbind :: Name -> Elab' aux () diff --git a/src/Idris/Core/Evaluate.hs b/src/Idris/Core/Evaluate.hs --- a/src/Idris/Core/Evaluate.hs +++ b/src/Idris/Core/Evaluate.hs @@ -8,7 +8,8 @@ Context, initContext, ctxtAlist, uconstraints, next_tvar, addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl, addDatatype, addCasedef, simplifyCasedef, addOperator, - lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact, lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupVal, + lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact, + lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal, mapDefCtxt, lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName, Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions, @@ -88,12 +89,17 @@ = evalState (do val <- eval tr ctxt [] (map finalEntry env) (finalise t) [] quote 0 val) initEval -specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> TT Name +-- Return a specialised name, and an updated list of reductions available, +-- so that the caller can tell how much specialisation was achieved. +specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> + (TT Name, [(Name, Int)]) specialise ctxt env limits t - = evalState (do val <- eval False ctxt [] + = let (tm, st) = + runState (do val <- eval False ctxt [] (map finalEntry env) (finalise t) [Spec] - quote 0 val) (initEval { limited = limits }) + quote 0 val) (initEval { limited = limits }) in + (tm, limited st) -- | Like normalise, but we only reduce functions that are marked as okay to -- inline (and probably shouldn't reduce lets?) @@ -167,13 +173,17 @@ _ -> return $ (True, (n, 100) : filter (\ (n', _) -> n/=n') ns) -deduct :: Name -> Eval () -deduct n = do ES ls num <- get +fnCount :: Int -> Name -> Eval () +fnCount inc n + = do ES ls num <- get case lookup n ls of - Just i -> do put $ ES ((n, (i-1)) : + Just i -> do put $ ES ((n, (i - inc)) : filter (\ (n', _) -> n/=n') ls) num _ -> return () +deduct = fnCount 1 +reinstate = fnCount (-1) + -- | Evaluate in a context of locally named things (i.e. not de Bruijn indexed, -- such as we might have during construction of a proof) @@ -380,8 +390,11 @@ | length ns <= length args = do let args' = take (length ns) args let rest = drop (length ns) args - when spec $ deduct n -- successful, so deduct usages + when spec $ deduct n t <- evTree ntimes stk top env (zip ns args') tree + when spec $ case t of + Nothing -> reinstate n -- Blocked, count n again + Just _ -> return () -- (zipWith (\n , t) -> (n, t)) ns args') tree return (t, rest) | otherwise = return (Nothing, args) @@ -973,6 +986,14 @@ [(Def, Accessibility)] lookupDefAcc n mkpublic ctxt = map mkp $ lookupCtxt n (definitions ctxt) + -- io_bind a special case for REPL prettiness + where mkp (d, a, _, _) = if mkpublic && (not (n == sUN "io_bind" || n == sUN "io_return")) + then (d, Public) else (d, a) + +lookupDefAccExact :: Name -> Bool -> Context -> + Maybe (Def, Accessibility) +lookupDefAccExact n mkpublic ctxt + = fmap mkp $ lookupCtxtExact n (definitions ctxt) -- io_bind a special case for REPL prettiness where mkp (d, a, _, _) = if mkpublic && (not (n == sUN "io_bind" || n == sUN "io_return")) then (d, Public) else (d, a) diff --git a/src/Idris/Core/Execute.hs b/src/Idris/Core/Execute.hs --- a/src/Idris/Core/Execute.hs +++ b/src/Idris/Core/Execute.hs @@ -60,6 +60,7 @@ | EBind Name (Binder ExecVal) (ExecVal -> Exec ExecVal) | EApp ExecVal ExecVal | EType UExp + | EUType Universe | EErased | EConstant Const | forall a. EPtr (Ptr a) @@ -72,6 +73,7 @@ show (EBind n b body) = "EBind " ++ show b ++ " <>" show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")" show (EType _) = "Type" + show (EUType _) = "UType" show EErased = "[__]" show (EConstant c) = show c show (EPtr p) = "<>" @@ -102,6 +104,7 @@ e2' <- toTT e2 return $ App e1' e2' toTT (EType u) = return $ TType u +toTT (EUType u) = return $ UType u toTT EErased = return Erased toTT (EConstant c) = return (Constant c) toTT (EThunk ctxt env tm) = do env' <- mapM toBinder env @@ -205,6 +208,7 @@ doExec env ctxt Erased = return EErased doExec env ctxt Impossible = fail "Tried to execute an impossible case" doExec env ctxt (TType u) = return (EType u) +doExec env ctxt (UType u) = return (EUType u) execApp :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal execApp env ctxt v [] = return v -- no args is just a constant! can result from function calls @@ -404,7 +408,7 @@ -- | Look up primitive operations in the global table and transform them into ExecVal functions getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal) getOp fn [_, _, x] | fn == pbm = Just (return x) -getOp fn [EP _ fn' _] +getOp fn [EP _ fn' _] | fn == prs && fn' == pstd = Just $ do line <- execIO getLine return (EConstant (Str line)) @@ -548,7 +552,7 @@ _ -> trace ("failed to construct ffun") Nothing getFTy :: ExecVal -> Maybe FType -getFTy (EApp (EP _ (UN fi) _) (EP _ (UN intTy) _)) +getFTy (EApp (EP _ (UN fi) _) (EP _ (UN intTy) _)) | fi == txt "FIntT" = case str intTy of "ITNative" -> Just (FArith (ATInt ITNative)) diff --git a/src/Idris/Core/ProofState.hs b/src/Idris/Core/ProofState.hs --- a/src/Idris/Core/ProofState.hs +++ b/src/Idris/Core/ProofState.hs @@ -618,8 +618,8 @@ (tmv, tmt) <- lift $ check ctxt env tm let tmt' = normalise ctxt env tmt let (tacn, tacstr, tactt) = if induction - then (ElimN, "an eliminator", "induction") - else (CaseN, "a case function", "case analysis") + then (ElimN, "an eliminator", "Induction") + else (CaseN, "a case function", "Case analysis") case unApply tmt' of (P _ tnm _, tyargs) -> do case lookupTy (SN (tacn tnm)) ctxt of @@ -651,10 +651,10 @@ mapM_ addConsHole (reverse consargs') let res' = forget $ res (scv, sct) <- lift $ check ctxt env res' - let scv' = specialise ctxt env [] scv + let (scv', _) = specialise ctxt env [] scv return scv' - [] -> fail $ tactt ++ " needs " ++ tacstr ++ " for " ++ show tnm - xs -> fail $ "Multiple definitions found when searching for " ++ tacstr ++ "of " ++ show tnm + [] -> lift $ tfail $ Msg $ tactt ++ " needs " ++ tacstr ++ " for " ++ show tnm + xs -> lift $ tfail $ Msg $ "Multiple definitions found when searching for " ++ tacstr ++ "of " ++ show tnm _ -> fail $ "Unkown type for " ++ if induction then "induction" else "case analysis" where scname = sMN 0 "scarg" makeConsArg (nm, ty) = P Bound nm ty @@ -705,7 +705,7 @@ -- reduce let bindings only simplify :: RunTactic simplify ctxt env (Bind x (Hole ty) sc) = - do return $ Bind x (Hole (specialise ctxt env [] ty)) sc + do return $ Bind x (Hole (fst (specialise ctxt env [] ty))) sc simplify ctxt env t = return t check_in :: Raw -> RunTactic diff --git a/src/Idris/Core/TT.hs b/src/Idris/Core/TT.hs --- a/src/Idris/Core/TT.hs +++ b/src/Idris/Core/TT.hs @@ -29,7 +29,8 @@ import Data.Char import Numeric (showIntAtBase) import qualified Data.Text as T -import Data.List +import Data.List hiding (insert) +import Data.Set(Set, member, fromList, insert) import Data.Maybe (listToMaybe) import Data.Foldable (Foldable) import Data.Traversable (Traversable) @@ -102,6 +103,8 @@ | AnnFC FC | AnnTextFmt TextFormatting | AnnTerm [(Name, Bool)] (TT Name) -- ^ pprint bound vars, original term + | AnnSearchResult Ordering -- ^ more general, isomorphic, or more specific + | AnnErr Err -- | Used for error reflection data ErrorReportPart = TextPart String @@ -116,7 +119,7 @@ -- | Idris errors. Used as exceptions in the compiler, but reported to users -- if they reach the top level. -data Err' t +data Err' t = Msg String | InternalMsg String | CantUnify Bool t t (Err' t) [(Name, t)] Int @@ -1134,13 +1137,18 @@ uniqueName n hs | n `elem` hs = uniqueName (nextName n) hs | otherwise = n +uniqueNameSet :: Name -> Set Name -> Name +uniqueNameSet n hs | n `member` hs = uniqueNameSet (nextName n) hs + | otherwise = n + uniqueBinders :: [Name] -> TT Name -> TT Name -uniqueBinders ns (Bind n b sc) - = let n' = uniqueName n ns - ns' = n' : ns in - Bind n' (fmap (uniqueBinders ns') b) (uniqueBinders ns' sc) -uniqueBinders ns (App f a) = App (uniqueBinders ns f) (uniqueBinders ns a) -uniqueBinders ns t = t +uniqueBinders ns = ubSet (fromList ns) where + ubSet ns (Bind n b sc) + = let n' = uniqueNameSet n ns + ns' = insert n' ns in + Bind n' (fmap (ubSet ns') b) (ubSet ns' sc) + ubSet ns (App f a) = App (ubSet ns f) (ubSet ns a) + ubSet ns t = t nextName (NS x s) = NS (nextName x) s diff --git a/src/Idris/Core/Unify.hs b/src/Idris/Core/Unify.hs --- a/src/Idris/Core/Unify.hs +++ b/src/Idris/Core/Unify.hs @@ -222,7 +222,7 @@ = Bind n (Hole ty) (instantiate (P Bound n ty) sc) explicitHole t = t -trimSolutions ns = dropPairs ns +trimSolutions ns = followSols (dropPairs ns) where dropPairs [] = [] dropPairs (n@(x, P _ x' _) : ns) | x == x' = dropPairs ns @@ -232,7 +232,13 @@ (n, P _ n' _) -> not (n == x' && n' == x) _ -> True) ns) dropPairs (n : ns) = n : dropPairs ns - + + followSols [] = [] + followSols ((n, P _ t _) : ns) + | Just t' <- lookup t ns + = followSols ((n, t') : ns) -- Are we guaranteed no cycles? + followSols (n : ns) = n : followSols ns + expandLets env (x, tm) = (x, doSubst (reverse env) tm) where doSubst [] tm = tm diff --git a/src/Idris/Coverage.hs b/src/Idris/Coverage.hs --- a/src/Idris/Coverage.hs +++ b/src/Idris/Coverage.hs @@ -65,7 +65,7 @@ logLvl 5 $ show lhss logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args) logLvl 10 $ show argss ++ "\n" ++ show all_args - logLvl 1 $ "Original: \n" ++ + logLvl 3 $ "Original: \n" ++ showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs) -- add an infinite supply of explicit arguments to update the possible -- cases for (the return type may be variadic, or function type, so @@ -76,11 +76,11 @@ p ++ repeat (PExp 0 [] (sMN 0 "gcarg") Placeholder) _ -> repeat (pexp Placeholder) let tryclauses = mkClauses parg all_args - logLvl 2 $ show (length tryclauses) ++ " initially to check" - logLvl 1 $ showSep "\n" (map (showTm i) tryclauses) + logLvl 3 $ show (length tryclauses) ++ " initially to check" + logLvl 2 $ showSep "\n" (map (showTm i) tryclauses) let new = filter (noMatch i) (nub tryclauses) - logLvl 1 $ show (length new) ++ " clauses to check for impossibility" - logLvl 3 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new) + logLvl 2 $ show (length new) ++ " clauses to check for impossibility" + logLvl 4 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new) -- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses) return new -- return (map (\t -> PClause n t [] PImpossible []) new) @@ -468,8 +468,8 @@ buildSCG (_, n) = do ist <- getIState case lookupCtxt n (idris_callgraph ist) of - [cg] -> case lookupDef n (tt_ctxt ist) of - [CaseOp _ _ _ pats _ cd] -> + [cg] -> case lookupDefExact n (tt_ctxt ist) of + Just (CaseOp _ _ _ pats _ cd) -> let (args, sc) = cases_totcheck cd in do logLvl 2 $ "Building SCG for " ++ show n ++ " from\n" ++ show pats ++ "\n" ++ show sc diff --git a/src/Idris/DataOpts.hs b/src/Idris/DataOpts.hs --- a/src/Idris/DataOpts.hs +++ b/src/Idris/DataOpts.hs @@ -97,6 +97,7 @@ -- Nat special cases -- TODO: Would be nice if this was configurable in idris source! + -- Issue #1597 https://github.com/idris-lang/Idris-dev/issues/1597 doOpts (NS (UN z) [nat, prelude]) [] | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude" = Constant (BI 0) @@ -105,4 +106,3 @@ = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1)) doOpts n args = mkApp (P (DCon tag arity uniq) n Erased) args - diff --git a/src/Idris/DeepSeq.hs b/src/Idris/DeepSeq.hs --- a/src/Idris/DeepSeq.hs +++ b/src/Idris/DeepSeq.hs @@ -7,46 +7,46 @@ import Control.DeepSeq import qualified Cheapskate.Types as CT +import qualified Idris.Docstrings as D --- Manual from imported libs -instance NFData CT.Doc where - rnf (CT.Doc opts contents) = rnf opts `seq` rnf contents `seq` () +instance NFData a => NFData (D.Docstring a) where + rnf (D.DocString opts contents) = rnf opts `seq` rnf contents `seq` () instance NFData CT.Options where - rnf (CT.Options x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (CT.Options x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () -instance NFData CT.Block where - rnf (CT.Para lines) = rnf lines `seq` () - rnf (CT.Header i lines) = rnf i `seq` rnf lines `seq` () - rnf (CT.Blockquote bs) = rnf bs `seq` () - rnf (CT.List b t xs) = rnf b `seq` rnf t `seq` rnf xs `seq` () - rnf (CT.CodeBlock attr txt) = rnf attr `seq` rnf txt `seq` () - rnf (CT.HtmlBlock txt) = rnf txt `seq` () - rnf CT.HRule = () +instance NFData a => NFData (D.Block a) where + rnf (D.Para lines) = rnf lines `seq` () + rnf (D.Header i lines) = rnf i `seq` rnf lines `seq` () + rnf (D.Blockquote bs) = rnf bs `seq` () + rnf (D.List b t xs) = rnf b `seq` rnf t `seq` rnf xs `seq` () + rnf (D.CodeBlock attr txt tm) = rnf attr `seq` rnf txt `seq` () + rnf (D.HtmlBlock txt) = rnf txt `seq` () + rnf D.HRule = () -instance NFData CT.Inline where - rnf (CT.Str txt) = rnf txt `seq` () - rnf CT.Space = () - rnf CT.SoftBreak = () - rnf CT.LineBreak = () - rnf (CT.Emph xs) = rnf xs `seq` () - rnf (CT.Strong xs) = rnf xs `seq` () - rnf (CT.Code xs) = rnf xs `seq` () - rnf (CT.Link a b xs) = rnf a `seq` rnf b `seq` rnf xs `seq` () - rnf (CT.Image a b c) = rnf a `seq` rnf b `seq` rnf c `seq` () - rnf (CT.Entity a) = rnf a `seq` () - rnf (CT.RawHtml x) = rnf x `seq` () +instance NFData a => NFData (D.Inline a) where + rnf (D.Str txt) = rnf txt `seq` () + rnf D.Space = () + rnf D.SoftBreak = () + rnf D.LineBreak = () + rnf (D.Emph xs) = rnf xs `seq` () + rnf (D.Strong xs) = rnf xs `seq` () + rnf (D.Code xs tm) = rnf xs `seq` rnf tm `seq` () + rnf (D.Link a b xs) = rnf a `seq` rnf b `seq` rnf xs `seq` () + rnf (D.Image a b c) = rnf a `seq` rnf b `seq` rnf c `seq` () + rnf (D.Entity a) = rnf a `seq` () + rnf (D.RawHtml x) = rnf x `seq` () instance NFData CT.ListType where - rnf (CT.Bullet c) = rnf c `seq` () - rnf (CT.Numbered nw i) = rnf nw `seq` rnf i `seq` () + rnf (CT.Bullet c) = rnf c `seq` () + rnf (CT.Numbered nw i) = rnf nw `seq` rnf i `seq` () instance NFData CT.CodeAttr where - rnf (CT.CodeAttr a b) = rnf a `seq` rnf b `seq` () + rnf (CT.CodeAttr a b) = rnf a `seq` rnf b `seq` () instance NFData CT.NumWrapper where - rnf CT.PeriodFollowing = () - rnf CT.ParenFollowing = () + rnf CT.PeriodFollowing = () + rnf CT.ParenFollowing = () -- All generated by 'derive' @@ -202,7 +202,6 @@ rnf (PMatchApp x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PCase x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (PTrue x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (PFalse x1) = rnf x1 `seq` () rnf (PRefl x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PResolveTC x1) = rnf x1 `seq` () rnf (PEq x1 x2 x3 x4 x5) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` () diff --git a/src/Idris/Delaborate.hs b/src/Idris/Delaborate.hs --- a/src/Idris/Delaborate.hs +++ b/src/Idris/Delaborate.hs @@ -9,7 +9,7 @@ import Idris.AbsSyntax import Idris.Core.TT import Idris.Core.Evaluate -import Idris.Docstrings (overview, renderDocstring) +import Idris.Docstrings (overview, renderDocstring, renderDocTerm) import Idris.ErrReverse import Data.List (intersperse, nub) @@ -50,7 +50,6 @@ | otherwise = PRef un (sUN ("v" ++ show i ++ "")) de env _ (P _ n _) | n == unitTy = PTrue un IsType | n == unitCon = PTrue un IsTerm - | n == falseTy = PFalse un | Just n' <- lookup n env = PRef un n' | otherwise = case lookup n (idris_metavars ist) of @@ -104,10 +103,10 @@ (de env [] l) (de env [] r) | n == sUN "Sg_intro" = PDPair un IsTerm (de env [] l) Placeholder (de env [] r) - deFn env f@(P _ n _) args - | n `elem` map snd env + deFn env f@(P _ n _) args + | n `elem` map snd env = PApp un (de env [] f) (map pexp (map (de env []) args)) - deFn env (P _ n _) args + deFn env (P _ n _) args | not mvs = case lookup n (idris_metavars ist) of Just (Just _, mi, _) -> mkMVApp n (drop mi (map (de env []) args)) @@ -170,10 +169,10 @@ pprintErr' i (CantUnify _ x_in y_in e sc s) = let (x_ns, y_ns, nms) = renameMNs x_in y_in (x, y) = addImplicitDiffs (delab i x_ns) (delab i y_ns) in - text "Can't unify" <> indented (annTm x_ns + text "Can't unify" <> indented (annTm x_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) sc ++ zip nms (repeat False)) x)) <$> - text "with" <> indented (annTm y_ns + text "with" <> indented (annTm y_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) sc ++ zip nms (repeat False)) y)) <> case e of @@ -183,10 +182,10 @@ if (opt_errContext (idris_options i)) then showSc i sc else empty pprintErr' i (CantConvert x y env) = text "Can't convert" <> - indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) + indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i (flagUnique x)))) <$> text "with" <> - indented (annTm y (pprintTerm' i (map (\ (n, b) -> (n, False)) env) + indented (annTm y (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i (flagUnique y)))) <> if (opt_errContext (idris_options i)) then line <> showSc i env else empty where flagUnique (Bind n (Pi t k@(UType u)) sc) @@ -232,7 +231,7 @@ pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n pprintErr' i (IncompleteTerm t) = text "Incomplete term" <+> annTm t (pprintTerm i (delab i t)) pprintErr' i UniverseError = text "Universe inconsistency" -pprintErr' i (UniqueError NullType n) +pprintErr' i (UniqueError NullType n) = text "Borrowed name" <+> annName' n (showbasic n) <+> text "must not be used on RHS" pprintErr' i (UniqueError _ n) = text "Unique name" <+> annName' n (showbasic n) @@ -253,9 +252,11 @@ annName' n (showqual i n) <> colon <$> pprintErr' i e pprintErr' i (ElaboratingArg f x _ e) + | isInternal f = pprintErr' i e | isUN x = text "When elaborating argument" <+> - annotate (AnnBoundName x False) (text (showbasic x)) <+> --TODO check plicity + annotate (AnnBoundName x False) (text (showbasic x)) <+> -- TODO check plicity + -- Issue #1591 on the issue tracker: https://github.com/idris-lang/Idris-dev/issues/1591 text "to" <+> whatIsName <> annName f <> colon <> indented (pprintErr' i e) | otherwise = @@ -269,6 +270,11 @@ else if isFnName f ctxt then text "function" <> space else empty + isInternal (MN _ _) = True + isInternal (UN n) = T.isPrefixOf (T.pack "__") n + isInternal (NS n _) = isInternal n + isInternal _ = True + pprintErr' i (ProviderError msg) = text ("Type provider error: " ++ msg) pprintErr' i (LoadingFailed fn e) = text "Loading" <+> text fn <+> text "failed:" <+> pprintErr' i e pprintErr' i (ReflectionError parts orig) = @@ -289,7 +295,11 @@ -- Make sure the machine invented names are shown helpfully to the user, so -- that any names which differ internally also differ visibly + -- FIXME: I can't actually contrive an error to test this! Will revisit later... +-- +-- Issue #1590 in the Issue tracker. +-- https://github.com/idris-lang/Idris-dev/issues/1590 renameMNs :: Term -> Term -> (Term, Term, [Name]) renameMNs x y = let ns = nub $ allTTNames x ++ allTTNames y newnames = evalState (getRenames [] ns) 1 in @@ -307,7 +317,7 @@ rename :: [(Name, Name)] -> Term -> Term rename ns (P nt x t) | Just x' <- lookup x ns = P nt x' t rename ns (App f a) = App (rename ns f) (rename ns a) - rename ns (Bind x b sc) + rename ns (Bind x b sc) = let b' = fmap (rename ns) b sc' = rename ns sc in case lookup x ns of @@ -318,15 +328,15 @@ -- If the two terms only differ in their implicits, mark the implicits which -- differ as AlwaysShow so that they appear in errors addImplicitDiffs :: PTerm -> PTerm -> (PTerm, PTerm) -addImplicitDiffs x y +addImplicitDiffs x y = if (x `expLike` y) then addI x y else (x, y) where addI :: PTerm -> PTerm -> (PTerm, PTerm) - addI (PApp fc f as) (PApp gc g bs) + addI (PApp fc f as) (PApp gc g bs) = let (as', bs') = addShows as bs in (PApp fc f as', PApp gc g bs') where addShows [] [] = ([], []) - addShows (a:as) (b:bs) + addShows (a:as) (b:bs) = let (as', bs') = addShows as bs (a', b') = addI (getTm a) (getTm b) in if (not (a' `expLike` b')) @@ -334,20 +344,20 @@ getTm = a' } : as', b { argopts = AlwaysShow : argopts b, getTm = b' } : bs') - else (a { getTm = a' } : as', + else (a { getTm = a' } : as', b { getTm = b' } : bs') - addI (PLam n a b) (PLam n' c d) + addI (PLam n a b) (PLam n' c d) = let (a', c') = addI a c (b', d') = addI b d in (PLam n a' b', PLam n' c' d') - addI (PPi p n a b) (PPi p' n' c d) + addI (PPi p n a b) (PPi p' n' c d) = let (a', c') = addI a c (b', d') = addI b d in (PPi p n a' b', PPi p' n' c' d') - addI (PRefl fc a) (PRefl fc' b) + addI (PRefl fc a) (PRefl fc' b) = let (a', b') = addI a b in (PRefl fc a', PRefl fc' b') - addI (PEq fc at bt a b) (PEq fc' ct dt c d) + addI (PEq fc at bt a b) (PEq fc' ct dt c d) | trace (show (at,bt)) False = undefined | at `expLike` ct && bt `expLike` dt = let (a', c') = addI a c @@ -357,8 +367,8 @@ = let (at', ct') = addI at ct (bt', dt') = addI bt dt (a', c') = addI a c - (b', d') = addI b d - showa = if at `expLike` ct then [] else [AlwaysShow] + (b', d') = addI b d + showa = if at `expLike` ct then [] else [AlwaysShow] showb = if bt `expLike` dt then [] else [AlwaysShow] in (PApp fc (PRef fc eqTy) [(pimp (sUN "A") at' True) { argopts = showa }, @@ -370,12 +380,12 @@ (pimp (sUN "B") dt' True) { argopts = showb }, pexp c', pexp d']) - - addI (PPair fc pi a b) (PPair fc' pi' c d) + + addI (PPair fc pi a b) (PPair fc' pi' c d) = let (a', c') = addI a c (b', d') = addI b d in (PPair fc pi a' b', PPair fc' pi' c' d') - addI (PDPair fc pi a t b) (PDPair fc' pi' c u d) + addI (PDPair fc pi a t b) (PDPair fc' pi' c u d) = let (a', c') = addI a c (t', u') = addI t u (b', d') = addI b d in @@ -387,19 +397,24 @@ expLike (PApp _ f as) (PApp _ f' as') = expLike f f' && length as == length as' && and (zipWith expLike (getExps as) (getExps as')) - expLike (PPi _ n s t) (PPi _ n' s' t') + expLike (PPi _ n s t) (PPi _ n' s' t') = n == n' && expLike s s' && expLike t t' - expLike (PLam n s t) (PLam n' s' t') + expLike (PLam n s t) (PLam n' s' t') = n == n' && expLike s s' && expLike t t' expLike (PPair _ _ x y) (PPair _ _ x' y') = expLike x x' && expLike y y' expLike (PDPair _ _ x _ y) (PDPair _ _ x' _ y') = expLike x x' && expLike y y' - expLike (PEq _ xt yt x y) (PEq _ xt' yt' x' y') + expLike (PEq _ xt yt x y) (PEq _ xt' yt' x' y') = expLike x x' && expLike y y' expLike (PRefl _ x) (PRefl _ x') = expLike x x' expLike x y = x == y +-- Issue #1589 on the issue tracker +-- https://github.com/idris-lang/Idris-dev/issues/1589 +-- +-- Figure out why MNs are getting rewritte to UNs for top-level +-- pattern-matching functions isUN :: Name -> Bool -isUN (UN n) = not $ T.isPrefixOf (T.pack "__") n -- TODO figure out why MNs are getting rewritte to UNs for top-level pattern-matching functions +isUN (UN n) = not $ T.isPrefixOf (T.pack "__") n -- TODO isUN (NS n _) = isUN n isUN _ = False @@ -426,9 +441,14 @@ _ | otherwise -> annot where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs docOverview ist n = do docs <- lookupCtxtExact n (idris_docstrings ist) - let o = overview (fst docs) + let o = overview (fst docs) + norm = normaliseAll (tt_ctxt ist) [] -- TODO make width configurable - out = displayS . renderPretty 1.0 50 $ renderDocstring o + -- Issue #1588 on the Issue Tracker + -- https://github.com/idris-lang/Idris-dev/issues/1588 + out = displayS . renderPretty 1.0 50 $ + renderDocstring (renderDocTerm (pprintDelab ist) + norm) o return (out "") getTy :: IState -> Name -> String -- fails if name not already extant! getTy ist n = let theTy = pprintPTerm (ppOptionIst ist) [] [] (idris_infixes ist) $ @@ -459,5 +479,3 @@ showbasic (MN _ s) = str s showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n showbasic (SN s) = show s - - diff --git a/src/Idris/Docs.hs b/src/Idris/Docs.hs --- a/src/Idris/Docs.hs +++ b/src/Idris/Docs.hs @@ -6,7 +6,7 @@ import Idris.Delaborate import Idris.Core.TT import Idris.Core.Evaluate -import Idris.Docstrings +import Idris.Docstrings (Docstring, emptyDocstring, noDocs, nullDocstring, renderDocstring, DocTerm, renderDocTerm) import Util.Pretty @@ -15,32 +15,34 @@ import qualified Data.Text as T -- TODO: Only include names with public/abstract accessibility - -data FunDoc = FD Name Docstring - [(Name, PTerm, Plicity, Maybe Docstring)] -- args: name, ty, implicit, docs +-- +-- Issue #1573 on the Issue tracker. +-- https://github.com/idris-lang/Idris-dev/issues/1573 +data FunDoc = FD Name (Docstring DocTerm) + [(Name, PTerm, Plicity, Maybe (Docstring DocTerm))] -- args: name, ty, implicit, docs PTerm -- function type (Maybe Fixity) - deriving Show data Docs = FunDoc FunDoc | DataDoc FunDoc -- type constructor docs [FunDoc] -- data constructor docs - | ClassDoc Name Docstring -- class docs + | ClassDoc Name (Docstring DocTerm)-- class docs [FunDoc] -- method docs - [(Name, Maybe Docstring)] -- parameters and their docstrings + [(Name, Maybe (Docstring DocTerm))] -- parameters and their docstrings [PTerm] -- instances [PTerm] -- superclasses - deriving Show -showDoc d | nullDocstring d = empty - | otherwise = text " -- " <> renderDocstring d +showDoc ist d + | nullDocstring d = empty + | otherwise = text " -- " <> + renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) d pprintFD :: IState -> FunDoc -> Doc OutputAnnotation pprintFD ist (FD n doc args ty f) = nest 4 (prettyName True (ppopt_impl ppo) [] n <+> colon <+> pprintPTerm ppo [] [ n | (n@(UN n'),_,_,_) <- args , not (T.isPrefixOf (T.pack "__") n') ] infixes ty <$> - renderDocstring doc <$> + renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) doc <$> maybe empty (\f -> text (show f) <> line) f <> let argshow = showArgs args [] in if not (null argshow) @@ -52,19 +54,19 @@ showArgs ((n, ty, Exp {}, Just d):args) bnd = bindingOf n False <+> colon <+> pprintPTerm ppo bnd [] infixes ty <> - showDoc d <> line + showDoc ist d <> line : showArgs args ((n, False):bnd) showArgs ((n, ty, Constraint {}, Just d):args) bnd = text "Class constraint" <+> - pprintPTerm ppo bnd [] infixes ty <> showDoc d <> line + pprintPTerm ppo bnd [] infixes ty <> showDoc ist d <> line : showArgs args ((n, True):bnd) showArgs ((n, ty, Imp {}, Just d):args) bnd = text "(implicit)" <+> bindingOf n True <+> colon <+> pprintPTerm ppo bnd [] infixes ty <> - showDoc d <> line + showDoc ist d <> line : showArgs args ((n, True):bnd) showArgs ((n, _, _, _):args) bnd = showArgs args ((n, True):bnd) @@ -80,7 +82,9 @@ vsep (map (pprintFD ist) args)) pprintDocs ist (ClassDoc n doc meths params instances superclasses) = nest 4 (text "Type class" <+> prettyName True (ppopt_impl ppo) [] n <> - if nullDocstring doc then empty else line <> renderDocstring doc) + if nullDocstring doc + then empty + else line <> renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) doc) <> line <$> nest 4 (text "Parameters:" <$> prettyParameters) <> line <$> @@ -131,7 +135,7 @@ (subclasses, instances') = partition isSubclass instances prettyParameters = if any (isJust . snd) params - then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty showDoc md) params) + then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty (showDoc ist) md) params) else hsep (punctuate comma (map (prettyName True False params' . fst) params)) getDocs :: Name -> Idris Docs @@ -182,10 +186,8 @@ where funName :: Name -> String funName (UN n) = str n funName (NS n _) = funName n - funName n - | n == falseTy = "_|_" -getPArgNames :: PTerm -> [(Name, Docstring)] -> [(Name, PTerm, Plicity, Maybe Docstring)] +getPArgNames :: PTerm -> [(Name, Docstring DocTerm)] -> [(Name, PTerm, Plicity, Maybe (Docstring DocTerm))] getPArgNames (PPi plicity name ty body) ds = (name, ty, plicity, lookup name ds) : getPArgNames body ds getPArgNames _ _ = [] diff --git a/src/Idris/Docstrings.hs b/src/Idris/Docstrings.hs --- a/src/Idris/Docstrings.hs +++ b/src/Idris/Docstrings.hs @@ -1,28 +1,139 @@ +{-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-} + -- | Wrapper around Markdown library module Idris.Docstrings ( - Docstring, parseDocstring, renderDocstring, emptyDocstring, nullDocstring, noDocs, - overview, containsText + Docstring(..), Block(..), Inline(..), parseDocstring, renderDocstring, emptyDocstring, nullDocstring, noDocs, + overview, containsText, renderHtml, annotCode, DocTerm(..), renderDocTerm, checkDocstring ) where import qualified Cheapskate as C import qualified Cheapskate.Types as CT +import Cheapskate.Html (renderDoc) import Util.Pretty -import Idris.Core.TT (OutputAnnotation(..), TextFormatting(..), Name) +import Idris.Core.TT (OutputAnnotation(..), TextFormatting(..), Name, Term, Err) import qualified Data.Text as T import qualified Data.Foldable as F +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) import qualified Data.Sequence as S --- | Representation of Idris's inline documentation -type Docstring = CT.Doc +import Control.DeepSeq (NFData(..)) +import Text.Blaze.Html (Html) + +-- | The various kinds of code samples that can be embedded in docs +data DocTerm = Unchecked + | Checked Term + | Example Term + | Failing Err + deriving Show + +-- | Render a term in the documentation +renderDocTerm :: (Term -> Doc OutputAnnotation) -> (Term -> Term) -> DocTerm -> String -> Doc OutputAnnotation +renderDocTerm pp norm Unchecked src = text src +renderDocTerm pp norm (Checked tm) src = pp tm +renderDocTerm pp norm (Example tm) src = align $ + text ">" <+> align (pp tm) <$> + pp (norm tm) +renderDocTerm pp norm (Failing err) src = annotate (AnnErr err) $ text src + +-- | Representation of Idris's inline documentation. The type paramter +-- represents the type of terms that are associated with code blocks. +data Docstring a = DocString CT.Options (Blocks a) + deriving (Show, Functor, Foldable, Traversable) + +type Blocks a = S.Seq (Block a) + +-- | Block-level elements. +data Block a = Para (Inlines a) + | Header Int (Inlines a) + | Blockquote (Blocks a) + | List Bool CT.ListType [Blocks a] + | CodeBlock CT.CodeAttr T.Text a + | HtmlBlock T.Text + | HRule + deriving (Show, Functor, Foldable, Traversable) + +data Inline a = Str T.Text + | Space + | SoftBreak + | LineBreak + | Emph (Inlines a) + | Strong (Inlines a) + | Code T.Text a + | Link (Inlines a) T.Text T.Text + | Image (Inlines a) T.Text T.Text + | Entity T.Text + | RawHtml T.Text + deriving (Show, Functor, Foldable, Traversable) + +type Inlines a = S.Seq (Inline a) + + +-- | Run some kind of processing step over code in a Docstring. The code +-- processor gets the language and annotations as parameters, along with the +-- source and the original annotation. +checkDocstring :: forall a b. (String -> [String] -> String -> a -> b) -> Docstring a -> Docstring b +checkDocstring f (DocString opts blocks) = DocString opts (fmap (checkBlock f) blocks) + where checkBlock :: (String -> [String] -> String -> a -> b) -> Block a -> Block b + checkBlock f (Para inlines) = Para (fmap (checkInline f) inlines) + checkBlock f (Header i inlines) = Header i (fmap (checkInline f) inlines) + checkBlock f (Blockquote bs) = Blockquote (fmap (checkBlock f) bs) + checkBlock f (List b t blocks) = List b t (fmap (fmap (checkBlock f)) blocks) + checkBlock f (CodeBlock attrs src tm) = CodeBlock attrs src + (f (T.unpack $ CT.codeLang attrs) + (words . T.unpack $ CT.codeInfo attrs) + (T.unpack src) + tm) + checkBlock f (HtmlBlock src) = HtmlBlock src + checkBlock f HRule = HRule + + checkInline :: (String -> [String] -> String -> a -> b) -> Inline a -> Inline b + checkInline f (Str txt) = Str txt + checkInline f Space = Space + checkInline f SoftBreak = SoftBreak + checkInline f LineBreak = LineBreak + checkInline f (Emph is) = Emph (fmap (checkInline f) is) + checkInline f (Strong is) = Strong (fmap (checkInline f) is) + checkInline f (Code src x) = Code src (f "" [] (T.unpack src) x) + checkInline f (Link is url title) = Link (fmap (checkInline f) is) url title + checkInline f (Image is url title) = Image (fmap (checkInline f) is) url title + checkInline f (Entity txt) = Entity txt + checkInline f (RawHtml src) = RawHtml src + -- | Construct a docstring from a Text that contains Markdown-formatted docs -parseDocstring :: T.Text -> CT.Doc -parseDocstring = C.markdown options +parseDocstring :: T.Text -> Docstring () +parseDocstring = toDocstring . C.markdown options + where toDocstring :: CT.Doc -> Docstring () + toDocstring (CT.Doc opts blocks) = DocString opts (fmap toBlock blocks) + toBlock :: CT.Block -> Block () + toBlock (CT.Para inlines) = Para (fmap toInline inlines) + toBlock (CT.Header i inlines) = Header i (fmap toInline inlines) + toBlock (CT.Blockquote blocks) = Blockquote (fmap toBlock blocks) + toBlock (CT.List b t blocks) = List b t (fmap (fmap toBlock) blocks) + toBlock (CT.CodeBlock attrs text) = CodeBlock attrs text () + toBlock (CT.HtmlBlock src) = HtmlBlock src + toBlock CT.HRule = HRule + toInline :: CT.Inline -> Inline () + toInline (CT.Str t) = Str t + toInline CT.Space = Space + toInline CT.SoftBreak = SoftBreak + toInline CT.LineBreak = LineBreak + toInline (CT.Emph is) = Emph (fmap toInline is) + toInline (CT.Strong is) = Strong (fmap toInline is) + toInline (CT.Code src) = Code src () + toInline (CT.Link is url title) = Link (fmap toInline is) url title + toInline (CT.Image is url title) = Image (fmap toInline is) url title + toInline (CT.Entity txt) = Entity txt + toInline (CT.RawHtml src) = RawHtml src + + options = CT.Options { CT.sanitize = True , CT.allowRawHtml = False , CT.preserveHardBreaks = True @@ -30,90 +141,152 @@ } -- | Convert a docstring to be shown by the pretty-printer -renderDocstring :: Docstring -> Doc OutputAnnotation -renderDocstring (CT.Doc _ blocks) = renderBlocks blocks +renderDocstring :: (a -> String -> Doc OutputAnnotation) -> Docstring a -> Doc OutputAnnotation +renderDocstring pp (DocString _ blocks) = renderBlocks pp blocks -- | Construct a docstring consisting of the first block-level element of the -- argument docstring, for use in summaries. -overview :: Docstring -> Docstring -overview (CT.Doc opts blocks) = CT.Doc opts (S.take 1 blocks) +overview :: Docstring a -> Docstring a +overview (DocString opts blocks) = DocString opts (S.take 1 blocks) -renderBlocks :: CT.Blocks -> Doc OutputAnnotation -renderBlocks blocks | S.length blocks > 1 = F.foldr1 (\b1 b2 -> b1 <> line <> line <> b2) $ - fmap renderBlock blocks - | S.length blocks == 1 = renderBlock (S.index blocks 0) - | otherwise = empty +renderBlocks :: (a -> String -> Doc OutputAnnotation) + -> Blocks a -> Doc OutputAnnotation +renderBlocks pp blocks | S.length blocks > 1 = F.foldr1 (\b1 b2 -> b1 <> line <> line <> b2) $ + fmap (renderBlock pp) blocks + | S.length blocks == 1 = renderBlock pp (S.index blocks 0) + | otherwise = empty -renderBlock :: CT.Block -> Doc OutputAnnotation -renderBlock (CT.Para inlines) = renderInlines inlines -renderBlock (CT.Header lvl inlines) = renderInlines inlines <+> parens (text (show lvl)) -renderBlock (CT.Blockquote blocks) = indent 8 $ renderBlocks blocks -renderBlock (CT.List b ty blockss) = renderList b ty blockss -renderBlock (CT.CodeBlock attr src) = indent 8 $ text (T.unpack src) -renderBlock (CT.HtmlBlock txt) = text "" -- TODO -renderBlock CT.HRule = text "----------------------" +renderBlock :: (a -> String -> Doc OutputAnnotation) + -> Block a -> Doc OutputAnnotation +renderBlock pp (Para inlines) = renderInlines pp inlines +renderBlock pp (Header lvl inlines) = renderInlines pp inlines <+> parens (text (show lvl)) +renderBlock pp (Blockquote blocks) = indent 8 $ renderBlocks pp blocks +renderBlock pp (List b ty blockss) = renderList pp b ty blockss +renderBlock pp (CodeBlock attr src tm) = indent 4 $ pp tm (T.unpack src) +renderBlock pp (HtmlBlock txt) = text "" -- TODO +renderBlock pp HRule = text "----------------------" -renderList :: Bool -> CT.ListType -> [CT.Blocks] -> Doc OutputAnnotation -renderList b (CT.Bullet c) blockss = vsep $ map (hang 4 . (char c <+>) . renderBlocks) blockss -renderList b (CT.Numbered nw i) blockss = +renderList :: (a -> String -> Doc OutputAnnotation) + -> Bool -> CT.ListType -> [Blocks a] -> Doc OutputAnnotation +renderList pp b (CT.Bullet c) blockss = vsep $ map (hang 4 . (char c <+>) . renderBlocks pp) blockss +renderList pp b (CT.Numbered nw i) blockss = vsep $ zipWith3 (\n p txt -> hang 4 $ text (show n) <> p <+> txt) - [i..] (repeat punc) (map renderBlocks blockss) + [i..] (repeat punc) (map (renderBlocks pp) blockss) where punc = case nw of CT.PeriodFollowing -> char '.' CT.ParenFollowing -> char '(' -renderInlines :: CT.Inlines -> Doc OutputAnnotation -renderInlines = F.foldr (<>) empty . fmap renderInline +renderInlines :: (a -> String -> Doc OutputAnnotation) -> Inlines a -> Doc OutputAnnotation +renderInlines pp = F.foldr (<>) empty . fmap (renderInline pp) -renderInline :: CT.Inline -> Doc OutputAnnotation -renderInline (CT.Str s) = text $ T.unpack s -renderInline CT.Space = softline -renderInline CT.SoftBreak = softline -renderInline CT.LineBreak = line -renderInline (CT.Emph txt) = annotate (AnnTextFmt ItalicText) $ renderInlines txt -- TODO -renderInline (CT.Strong txt) = annotate (AnnTextFmt BoldText) $ renderInlines txt -- TODO -renderInline (CT.Code txt) = text $ T.unpack txt -renderInline (CT.Link body url title) = annotate (AnnTextFmt UnderlineText) (renderInlines body) <+> +renderInline :: (a -> String -> Doc OutputAnnotation) -> Inline a -> Doc OutputAnnotation +renderInline pp (Str s) = text $ T.unpack s +renderInline pp Space = softline +renderInline pp SoftBreak = softline +renderInline pp LineBreak = line +renderInline pp (Emph txt) = annotate (AnnTextFmt ItalicText) $ renderInlines pp txt +renderInline pp (Strong txt) = annotate (AnnTextFmt BoldText) $ renderInlines pp txt +renderInline pp (Code txt tm) = pp tm $ T.unpack txt +renderInline pp (Link body url title) = annotate (AnnTextFmt UnderlineText) (renderInlines pp body) <+> parens (text $ T.unpack url) -renderInline (CT.Image body url title) = text "" -- TODO -renderInline (CT.Entity a) = text $ "" -- TODO -renderInline (CT.RawHtml txt) = text "" --TODO +renderInline pp (Image body url title) = text "" -- TODO +renderInline pp (Entity a) = text $ "" -- TODO +renderInline pp (RawHtml txt) = text "" --TODO -- | The empty docstring -emptyDocstring :: Docstring -emptyDocstring = CT.Doc options S.empty +emptyDocstring :: Docstring a +emptyDocstring = DocString options S.empty -- | Check whether a docstring is emtpy -nullDocstring :: Docstring -> Bool -nullDocstring (CT.Doc _ blocks) = S.null blocks +nullDocstring :: Docstring a -> Bool +nullDocstring (DocString _ blocks) = S.null blocks -- | Empty documentation for a definition -noDocs :: (Docstring, [(Name, Docstring)]) +noDocs :: (Docstring a, [(Name, Docstring a)]) noDocs = (emptyDocstring, []) -- | Does a string occur in the docstring? -containsText :: T.Text -> Docstring -> Bool -containsText str (CT.Doc _ blocks) = F.any (blockContains (T.toLower str)) blocks +containsText :: T.Text -> Docstring a -> Bool +containsText str (DocString _ blocks) = F.any (blockContains (T.toLower str)) blocks -- blockContains and inlineContains should always be called with a lower-case search string - where blockContains :: T.Text -> CT.Block -> Bool - blockContains str (CT.Para inlines) = F.any (inlineContains str) inlines - blockContains str (CT.Header lvl inlines) = F.any (inlineContains str) inlines - blockContains str (CT.Blockquote blocks) = F.any (blockContains str) blocks - blockContains str (CT.List b ty blockss) = F.any (F.any (blockContains str)) blockss - blockContains str (CT.CodeBlock attr src) = T.isInfixOf str (T.toLower src) - blockContains str (CT.HtmlBlock txt) = False -- TODO - blockContains str CT.HRule = False + where blockContains :: T.Text -> Block a -> Bool + blockContains str (Para inlines) = F.any (inlineContains str) inlines + blockContains str (Header lvl inlines) = F.any (inlineContains str) inlines + blockContains str (Blockquote blocks) = F.any (blockContains str) blocks + blockContains str (List b ty blockss) = F.any (F.any (blockContains str)) blockss + blockContains str (CodeBlock attr src _) = T.isInfixOf str (T.toLower src) + blockContains str (HtmlBlock txt) = False -- TODO + blockContains str HRule = False - inlineContains :: T.Text -> CT.Inline -> Bool - inlineContains str (CT.Str s) = T.isInfixOf str (T.toLower s) - inlineContains str CT.Space = False - inlineContains str CT.SoftBreak = False - inlineContains str CT.LineBreak = False - inlineContains str (CT.Emph txt) = F.any (inlineContains str) txt - inlineContains str (CT.Strong txt) = F.any (inlineContains str) txt - inlineContains str (CT.Code txt) = T.isInfixOf str (T.toLower txt) - inlineContains str (CT.Link body url title) = F.any (inlineContains str) body - inlineContains str (CT.Image body url title) = False - inlineContains str (CT.Entity a) = False - inlineContains str (CT.RawHtml txt) = T.isInfixOf str (T.toLower txt) + inlineContains :: T.Text -> Inline a -> Bool + inlineContains str (Str s) = T.isInfixOf str (T.toLower s) + inlineContains str Space = False + inlineContains str SoftBreak = False + inlineContains str LineBreak = False + inlineContains str (Emph txt) = F.any (inlineContains str) txt + inlineContains str (Strong txt) = F.any (inlineContains str) txt + inlineContains str (Code txt _) = T.isInfixOf str (T.toLower txt) + inlineContains str (Link body url title) = F.any (inlineContains str) body + inlineContains str (Image body url title) = False + inlineContains str (Entity a) = False + inlineContains str (RawHtml txt) = T.isInfixOf str (T.toLower txt) + + +renderHtml :: Docstring DocTerm -> Html +renderHtml = renderDoc . fromDocstring + where + fromDocstring :: Docstring DocTerm -> CT.Doc + fromDocstring (DocString opts blocks) = CT.Doc opts (fmap fromBlock blocks) + + fromBlock :: Block DocTerm -> CT.Block + fromBlock (Para inlines) = CT.Para (fmap fromInline inlines) + fromBlock (Header i inlines) = CT.Header i (fmap fromInline inlines) + fromBlock (Blockquote blocks) = CT.Blockquote (fmap fromBlock blocks) + fromBlock (List b t blocks) = CT.List b t (fmap (fmap fromBlock) blocks) + fromBlock (CodeBlock attrs text _) = CT.CodeBlock attrs text + fromBlock (HtmlBlock src) = CT.HtmlBlock src + fromBlock HRule = CT.HRule + + fromInline :: Inline DocTerm -> CT.Inline + fromInline (Str t) = CT.Str t + fromInline Space = CT.Space + fromInline SoftBreak = CT.SoftBreak + fromInline LineBreak = CT.LineBreak + fromInline (Emph is) = CT.Emph (fmap fromInline is) + fromInline (Strong is) = CT.Strong (fmap fromInline is) + fromInline (Code src _) = CT.Code src + fromInline (Link is url title) = CT.Link (fmap fromInline is) url title + fromInline (Image is url title) = CT.Image (fmap fromInline is) url title + fromInline (Entity txt) = CT.Entity txt + fromInline (RawHtml src) = CT.RawHtml src + + +-- | Annotate the code samples in a docstring +annotCode :: forall a b. (String -> b) -- ^ How to annotate code samples + -> Docstring a + -> Docstring b +annotCode annot (DocString opts blocks) + = DocString opts $ fmap annotCodeBlock blocks + where + annotCodeBlock :: Block a -> Block b + annotCodeBlock (Para inlines) = Para (fmap annotCodeInline inlines) + annotCodeBlock (Header i inlines) = Header i (fmap annotCodeInline inlines) + annotCodeBlock (Blockquote blocks) = Blockquote (fmap annotCodeBlock blocks) + annotCodeBlock (List b t blocks) = List b t (fmap (fmap annotCodeBlock) blocks) + annotCodeBlock (CodeBlock attrs src _) = CodeBlock attrs src (annot (T.unpack src)) + annotCodeBlock (HtmlBlock src) = HtmlBlock src + annotCodeBlock HRule = HRule + + annotCodeInline :: Inline a -> Inline b + annotCodeInline (Str t) = Str t + annotCodeInline Space = Space + annotCodeInline SoftBreak = SoftBreak + annotCodeInline LineBreak = LineBreak + annotCodeInline (Emph is) = Emph (fmap annotCodeInline is) + annotCodeInline (Strong is) = Strong (fmap annotCodeInline is) + annotCodeInline (Code src _) = Code src (annot (T.unpack src)) + annotCodeInline (Link is url title) = Link (fmap annotCodeInline is) url title + annotCodeInline (Image is url title) = Image (fmap annotCodeInline is) url title + annotCodeInline (Entity txt) = Entity txt + annotCodeInline (RawHtml src) = RawHtml src diff --git a/src/Idris/Elab/Class.hs b/src/Idris/Elab/Class.hs --- a/src/Idris/Elab/Class.hs +++ b/src/Idris/Elab/Class.hs @@ -52,9 +52,9 @@ data MArgTy = IA | EA | CA deriving Show -elabClass :: ElabInfo -> SyntaxInfo -> Docstring -> +elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> FC -> [PTerm] -> - Name -> [(Name, PTerm)] -> [(Name, Docstring)] -> [PDecl] -> Idris () + Name -> [(Name, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [PDecl] -> Idris () elabClass info syn_in doc fc constraints tn ps pDocs ds = do let cn = SN (InstanceCtorN tn) -- sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn) let tty = pibind ps PType @@ -220,7 +220,8 @@ insertConstraint c (PPi p@(Imp _ _ _) n ty sc) = PPi p n ty (insertConstraint c sc) - insertConstraint c sc = PPi constraint (sMN 0 "class") c sc + insertConstraint c sc = PPi (constraint { pstatic = Static }) + (sMN 0 "class") c sc -- make arguments explicit and don't bind class parameters toExp ns e (PPi (Imp l s p) n ty sc) diff --git a/src/Idris/Elab/Clause.hs b/src/Idris/Elab/Clause.hs --- a/src/Idris/Elab/Clause.hs +++ b/src/Idris/Elab/Clause.hs @@ -14,11 +14,13 @@ import Idris.Primitives import Idris.Inliner import Idris.PartialEval +import Idris.Transforms import Idris.DeepSeq -import Idris.Output (iputStrLn, pshow, iWarn) +import Idris.Output (iputStrLn, pshow, iWarn, iRenderResult) import IRTS.Lang import Idris.Elab.Type +import Idris.Elab.Transform import Idris.Elab.Utils import Idris.Core.TT @@ -28,7 +30,8 @@ import Idris.Core.Typecheck import Idris.Core.CaseTree -import Idris.Docstrings +import Idris.Docstrings hiding (Unchecked) +import Util.Pretty hiding ((<$>)) import Prelude hiding (id, (.)) import Control.Category @@ -48,6 +51,7 @@ import Data.List.Split (splitOn) import Util.Pretty(pretty, text) +import Numeric -- | Elaborate a collection of left-hand and right-hand pairs - that is, a -- top-level definition. @@ -55,6 +59,8 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in do ctxt <- getContext ist <- getIState + optimise <- getOptimise + let petrans = PETransform `elem` optimise inacc <- map fst <$> fgetState (opt_inaccessible . ist_optimisation n) -- Check n actually exists, with no definition yet @@ -70,9 +76,11 @@ let atys = map snd (getArgTys fty) cs_elab <- mapM (elabClause info opts) (zip [0..] cs) + -- pats_raw is the version we'll work with at compile time: + -- no simplification or PE let (pats_in, cs_full) = unzip cs_elab - - logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in + let pats_raw = map (simple_lhs (tt_ctxt ist)) pats_in + logLvl 3 $ "Elaborated patterns:\n" ++ show pats_raw solveDeferred n @@ -81,13 +89,38 @@ addIBC (IBCOpt n) ist <- getIState - let pats = map (simple_lhs (tt_ctxt ist)) $ doTransforms ist pats_in + -- Don't apply rules if this is a partial evaluation definition, + -- or we'll make something that just runs itself! + let tpats = case specNames opts of + Nothing -> transformPats ist pats_in + _ -> pats_in - -- logLvl 3 (showSep "\n" (map (\ (l,r) -> - -- show l ++ " = " ++ - -- show r) pats)) + -- If the definition is specialisable, this reduces the + -- RHS + pe_tm <- doPartialEval ist tpats + let pats_pe = if petrans + then map (simple_lhs (tt_ctxt ist)) pe_tm + else pats_raw + let tcase = opt_typecase (idris_options ist) + -- Look for 'static' names and generate new specialised + -- definitions for them, as well as generating rewrite rules + -- for partially evaluated definitions + newrules <- if petrans + then mapM (\ e -> case e of + Left _ -> return [] + Right (l, r) -> elabPE info fc n r) pats_pe + else return [] + + -- Redo transforms with the newly generated transformations, so + -- that the specialised application we've just made gets + -- used in place of the general one + ist <- getIState + let pats_transformed = if petrans + then transformPats ist pats_pe + else pats_pe + -- Summary of what's about to happen: Definitions go: -- -- pats_in -> pats -> pdef -> pdef' @@ -95,20 +128,15 @@ -- addCaseDef builds case trees from and -- pdef is the compile-time pattern definition. - -- This will get further optimised for run-time, and, separately, - -- further inlined to help with totality checking. - let pdef = map debind pats + -- This will get further inlined to help with totality checking. + let pdef = map debind pats_raw + -- pdef_pe is the one which will get further optimised + -- for run-time, and, partially evaluated + let pdef_pe = map debind pats_transformed - logLvl 5 $ "Initial typechecked patterns:\n" ++ show pats + logLvl 5 $ "Initial typechecked patterns:\n" ++ show pats_raw logLvl 5 $ "Initial typechecked pattern def:\n" ++ show pdef - -- Look for 'static' names and generate new specialised - -- definitions for them - - mapM_ (\ e -> case e of - Left _ -> return () - Right (l, r) -> elabPE info fc n r) pats - -- NOTE: Need to store original definition so that proofs which -- rely on its structure aren't affected by any changes to the -- inliner. Just use the inlined version to generate pdef' and to @@ -120,12 +148,14 @@ numArgs <- tclift $ sameLength pdef case specNames opts of - Just _ -> logLvl 5 $ "Partially evaluated:\n" ++ show pats + Just _ -> + do logLvl 3 $ "Partially evaluated:\n" ++ show pats_pe _ -> return () + logLvl 3 $ "Transformed:\n" ++ show pats_transformed erInfo <- getErasureInfo <$> getIState tree@(CaseDef scargs sc _) <- tclift $ - simpleCase tcase False reflect CompileTime fc inacc atys pdef erInfo + simpleCase tcase False reflect CompileTime fc inacc atys pdef erInfo cov <- coverage pmissing <- if cov && not (hasDefault cs) @@ -146,8 +176,9 @@ else return [] let pcover = null pmissing - -- pdef' is the version that gets compiled for run-time - pdef_in' <- applyOpts pdef + -- pdef' is the version that gets compiled for run-time, + -- so we start from the partially evaluated version + pdef_in' <- applyOpts pdef_pe let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in' logLvl 5 $ "After data structure transformations:\n" ++ show pdef' @@ -163,7 +194,6 @@ -- then case tot of -- Total _ -> return () -- t -> tclift $ tfail (At fc (Msg (show n ++ " is " ++ show t))) - -- else return () -- _ -> return () case tree of CaseDef _ _ [] -> return () @@ -180,7 +210,7 @@ ctxt <- getContext ist <- getIState let opt = idris_optimisation ist - putIState (ist { idris_patdefs = addDef n (force pdef', force pmissing) + putIState (ist { idris_patdefs = addDef n (force pdef_pe, force pmissing) (idris_patdefs ist) }) let caseInfo = CaseInfo (inlinable opts) (dictionary opts) case lookupTy n ctxt of @@ -190,8 +220,11 @@ (AssertTotal `elem` opts) atys inacc - pats - pdef pdef pdef_inl pdef' ty) + pats_pe + pdef + pdef -- compile time + pdef_inl -- inlined + pdef' ty) addIBC (IBCDef n) setTotality n tot when (not reflect) $ do totcheck (fc, n) @@ -244,22 +277,12 @@ getLHS (_, l, _) = l - simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, - force (normalisePats ctxt [] y)) + simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y) simple_lhs ctxt t = t simple_rt ctxt (p, x, y) = (p, x, force (uniqueBinders p (rt_simplify ctxt [] y))) - -- this is so pattern types are in the right form for erasure - normalisePats ctxt env (Bind n (PVar t) sc) - = let t' = normalise ctxt env t in - Bind n (PVar t') (normalisePats ctxt ((n, PVar t') : env) sc) - normalisePats ctxt env (Bind n (PVTy t) sc) - = let t' = normalise ctxt env t in - Bind n (PVTy t') (normalisePats ctxt ((n, PVar t') : env) sc) - normalisePats ctxt env t = t - specNames [] = Nothing specNames (Specialise ns : _) = Just ns specNames (_ : xs) = specNames xs @@ -271,63 +294,95 @@ else tfail (At fc (Msg "Clauses have differing numbers of arguments ")) sameLength [] = return 0 - -- apply all transformations (just specialisation for now, add - -- user defined transformation rules later) - doTransforms ist pats = + -- Partially evaluate, if the definition is marked as specialisable + doPartialEval ist pats = case specNames opts of - Nothing -> pats - Just ns -> partial_eval (tt_ctxt ist) ns pats + Nothing -> return pats + Just ns -> case partial_eval (tt_ctxt ist) ns pats of + Just t -> return t + Nothing -> ierror (At fc (Msg "No specialisation achieved")) --- | Find 'static' applications in a term and partially evaluate them -elabPE :: ElabInfo -> FC -> Name -> Term -> Idris () +-- | Find 'static' applications in a term and partially evaluate them. +-- Return any new transformation rules +elabPE :: ElabInfo -> FC -> Name -> Term -> Idris [(Term, Term)] elabPE info fc caller r = do ist <- getIState - let sa = getSpecApps ist [] r - mapM_ (mkSpecialised ist) sa - where - -- TODO: Add a PTerm level transformation rule, which is basically the - -- new definition in reverse (before specialising it). - -- RHS => LHS where implicit arguments are left blank in the + let sa = filter (\ap -> fst ap /= caller) $ getSpecApps ist [] r + rules <- mapM mkSpecialised sa + return $ concat rules + where + -- Make a specialised version of the application, and + -- add a PTerm level transformation rule, which is basically the + -- new definition in reverse (before specialising it). + -- RHS => LHS where implicit arguments are left blank in the -- transformation. - -- Apply that transformation after every PClauses elaboration + -- Transformation rules are applied after every PClause elaboration - mkSpecialised ist specapp_in = do + mkSpecialised :: (Name, [(PEArgType, Term)]) -> Idris [(Term, Term)] + mkSpecialised specapp_in = do + ist <- getIState let (specTy, specapp) = getSpecTy ist specapp_in - let (n, newnm, pats) = getSpecClause ist specapp - let undef = case lookupDef newnm (tt_ctxt ist) of - [] -> True + let (n, newnm, specdecl) = getSpecClause ist specapp + let lhs = pe_app specdecl + let rhs = pe_def specdecl + let undef = case lookupDefExact newnm (tt_ctxt ist) of + Nothing -> True _ -> False - logLvl 5 $ show (newnm, map (concreteArg ist) (snd specapp)) + logLvl 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp)) idrisCatch - (when (undef && all (concreteArg ist) (snd specapp)) $ do - cgns <- getAllNames n - let opts = [Specialise (map (\x -> (x, Nothing)) cgns ++ - mapMaybe specName (snd specapp))] - logLvl 3 $ "Specialising application: " ++ show specapp - logLvl 2 $ "New name: " ++ show newnm - iLOG $ "PE definition type : " ++ (show specTy) - ++ "\n" ++ show opts - logLvl 2 $ "PE definition " ++ show newnm ++ ":\n" ++ - showSep "\n" - (map (\ (lhs, rhs) -> - (showTmImpls lhs ++ " = " ++ - showTmImpls rhs)) pats) - elabType info defaultSyntax emptyDocstring [] fc opts newnm specTy - let def = map (\ (lhs, rhs) -> PClause fc newnm lhs [] rhs []) pats - elabClauses info fc opts newnm def - logLvl 2 $ "Specialised " ++ show newnm) + (if (undef && all (concreteArg ist) (snd specapp)) then do + cgns <- getAllNames n + -- on the RHS of the new definition, we should reduce + -- everything that's not itself static (because we'll + -- want to be a PE version of those next) + let cgns' = filter (\x -> x /= n && + notStatic ist x) cgns + let opts = [Specialise ((if pe_simple specdecl + then map (\x -> (x, Nothing)) cgns' + else []) ++ + (n, Just 65536) : + mapMaybe (specName (pe_simple specdecl)) + (snd specapp))] + logLvl 3 $ "Specialising application: " ++ show specapp + ++ " in " ++ show caller ++ + " with " ++ show opts + logLvl 3 $ "New name: " ++ show newnm + logLvl 3 $ "PE definition type : " ++ (show specTy) + ++ "\n" ++ show opts + logLvl 3 $ "PE definition " ++ show newnm ++ ":\n" ++ + showSep "\n" + (map (\ (lhs, rhs) -> + (show lhs ++ " = " ++ + showTmImpls rhs)) (pe_clauses specdecl)) + + logLvl 2 $ show n ++ " transformation rule: " ++ + show rhs ++ " ==> " ++ show lhs + + elabType info defaultSyntax emptyDocstring [] fc opts newnm specTy + let def = map (\(lhs, rhs) -> + PClause fc newnm lhs [] rhs []) + (pe_clauses specdecl) + trans <- elabTransform info fc False rhs lhs + elabClauses info fc opts newnm def + return [trans] + else return []) -- if it doesn't work, just don't specialise. Could happen for lots -- of valid reasons (e.g. local variables in scope which can't be -- lifted out). - (\e -> logLvl 4 $ "Couldn't specialise: " ++ (pshow ist e)) + (\e -> do logLvl 3 $ "Couldn't specialise: " ++ (pshow ist e) + return []) - specName (ImplicitS, tm) - | (P Ref n _, _) <- unApply tm = Just (n, Just 1) - specName (ExplicitS, tm) - | (P Ref n _, _) <- unApply tm = Just (n, Just 1) - specName _ = Nothing + specName simpl (ImplicitS, tm) + | (P Ref n _, _) <- unApply tm = Just (n, Just (if simpl then 1 else 0)) + specName simpl (ExplicitS, tm) + | (P Ref n _, _) <- unApply tm = Just (n, Just (if simpl then 1 else 0)) + specName simpl _ = Nothing + notStatic ist n = case lookupCtxtExact n (idris_statics ist) of + Just s -> not (or s) + _ -> True + concreteArg ist (ImplicitS, tm) = concreteTm ist tm concreteArg ist (ExplicitS, tm) = concreteTm ist tm concreteArg ist _ = True @@ -337,6 +392,8 @@ [] -> False _ -> True concreteTm ist (Constant _) = True + concreteTm ist (Bind n (Lam _) sc) = True + concreteTm ist (Bind n (Let _ _) sc) = concreteTm ist sc concreteTm ist _ = False -- get the type of a specialised application @@ -351,14 +408,20 @@ -- get the clause of a specialised application getSpecClause ist (n, args) - = let newnm = sUN ("__"++show (nsroot n) ++ "_" ++ - showSep "_" (map showArg args)) in + = let newnm = sUN ("PE_" ++ show (nsroot n) ++ "_" ++ + qhash 0 (showSep "_" (map showArg args))) in -- UN (show n ++ show (map snd args)) in (n, newnm, mkPE_TermDecl ist newnm n args) where showArg (ExplicitS, n) = show n showArg (ImplicitS, n) = show n showArg _ = "" + -- TMP for readability! This is obviously a really bad hashing + -- function. + qhash :: Int -> String -> String + qhash acc [] = showHex acc "" + qhash acc (x:xs) = qhash (fromEnum x + acc) xs + -- checks if the clause is a possible left hand side. Returns the term if -- possible, otherwise Nothing. @@ -388,8 +451,8 @@ validCase ctxt (Elaborating _ _ e) = validCase ctxt e validCase ctxt (ElaboratingArg _ _ _ e) = validCase ctxt e validCase ctxt _ = True - - recoverable ctxt (CantUnify r topx topy e _ _) + + recoverable ctxt (CantUnify r topx topy e _ _) = let topx' = normalise ctxt [] topx topy' = normalise ctxt [] topy in checkRec topx' topy' @@ -398,7 +461,7 @@ recoverable ctxt (ElaboratingArg _ _ _ e) = recoverable ctxt e recoverable _ _ = False - sameFam topx topy + sameFam topx topy = case (unApply topx, unApply topy) of ((P _ x _, _), (P _ y _, _)) -> x == y _ -> False @@ -409,11 +472,11 @@ checkRec (App f a) p@(P _ _ _) = checkRec f p checkRec p@(P _ _ _) (App f a) = checkRec p f - checkRec fa@(App _ _) fa'@(App _ _) + checkRec fa@(App _ _) fa'@(App _ _) | (f, as) <- unApply fa, (f', as') <- unApply fa' - = if (length as /= length as') - then checkRec f f' + = if (length as /= length as') + then checkRec f f' else checkRec f f' && and (zipWith checkRec as as') checkRec (P xt x _) (P yt y _) = x == y || ntRec xt yt checkRec _ _ = False @@ -463,7 +526,7 @@ let lhs = addImpl i lhs_in b <- checkPossible info fc tcgen fname lhs_in case b of - True -> tclift $ tfail (At fc + True -> tclift $ tfail (At fc (Msg $ show lhs_in ++ " is a valid case")) False -> do ptm <- mkPatTm lhs_in return (Left ptm, lhs) @@ -501,6 +564,8 @@ let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs' + let static_names = getStaticNames i lhs_tm + logLvl 3 ("Elaborated: " ++ show lhs_tm) logLvl 3 ("Elaborated type: " ++ show lhs_ty) logLvl 5 ("Injective: " ++ show fname ++ " " ++ show inj) @@ -516,9 +581,11 @@ -- These are the names we're not allowed to use on the RHS, because -- they're UniqueTypes and borrowed from another function. -- FIXME: There is surely a nicer way than this... + -- Issue #1615 on the Issue Tracker. + -- https://github.com/idris-lang/Idris-dev/issues/1615 when (not (null borrowed)) $ logLvl 5 ("Borrowed names on LHS: " ++ show borrowed) - + logLvl 3 ("Normalised LHS: " ++ showTmImpls (delabMV i clhs)) rep <- useREPL @@ -541,7 +608,8 @@ let newargs = filter (\(n,_) -> n `notElem` uniqargs) newargs_all let winfo = pinfo info newargs defs windex - let wb = map (expandParamsD False ist decorate newargs defs) whereblock + let wb = map (mkStatic static_names) $ + map (expandParamsD False ist decorate newargs defs) whereblock -- Split the where block into declarations with a type, and those -- without @@ -562,7 +630,7 @@ tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty [] (do pbinds ist lhs_tm mapM_ setinj (nub (params ++ inj)) - setNextName + setNextName (_, _, is) <- errAt "right hand side of " fname (erun fc (build i winfo ERHS opts fname rhs)) errAt "right hand side of " fname @@ -579,7 +647,7 @@ logLvl 5 "DONE CHECK" logLvl 2 $ "---> " ++ show rhs' - when (not (null defer)) $ iLOG $ "DEFERRED " ++ + when (not (null defer)) $ iLOG $ "DEFERRED " ++ show (map (\ (n, (_,_,t)) -> (n, t)) defer) def' <- checkDef fc defer let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def' @@ -599,7 +667,7 @@ logLvl 5 $ "Rechecking" logLvl 6 $ " ==> " ++ show (forget rhs') - (crhs, crhsty) <- if not inf + (crhs, crhsty) <- if not inf then recheckC_borrowing True borrowed fc [] rhs' else return (rhs', clhsty) logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty @@ -612,16 +680,16 @@ -- then we'll try running it in reverse to improve error messages let (ret_fam, _) = unApply (getRetTy crhsty) rev <- case ret_fam of - P _ rfamn _ -> + P _ rfamn _ -> case lookupCtxt rfamn (idris_datatypes i) of - [TI _ _ dopts _ _] -> + [TI _ _ dopts _ _] -> return (DataErrRev `elem` dopts) _ -> return False _ -> return False when (rev || ErrorReverse `elem` opts) $ do addIBC (IBCErrRev (crhs, clhs)) - addErrRev (crhs, clhs) + addErrRev (crhs, clhs) return $ (Right (clhs, crhs), lhs) where pinfo :: ElabInfo -> [(Name, PTerm)] -> [Name] -> Int -> ElabInfo @@ -641,7 +709,7 @@ -- we know they can't be used on the RHS borrowedNames :: [Name] -> Term -> [Name] borrowedNames env (App (App (P _ (NS (UN lend) [owner]) _) _) arg) - | owner == txt "Ownership" && + | owner == txt "Ownership" && (lend == txt "lend" || lend == txt "Read") = getVs arg where getVs (V i) = [env!!i] @@ -653,7 +721,7 @@ borrowedB b = borrowedNames env (binderTy b) borrowedNames _ _ = [] - mkLHSapp t@(PRef _ _) = trace ("APP " ++ show t) $ PApp fc t [] + mkLHSapp t@(PRef _ _) = PApp fc t [] mkLHSapp t = t decorate (NS x ns) @@ -689,7 +757,7 @@ isArg :: Name -> PDecl -> Bool isArg n (PClauses _ _ _ cs) = any isArg' cs where - isArg' (PClause _ _ (PApp _ _ args) _ _ _) + isArg' (PClause _ _ (PApp _ _ args) _ _ _) = any (\x -> case x of PRef _ n' -> n == n' _ -> False) (map getTm args) @@ -719,7 +787,8 @@ let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs' let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty)) - logLvl 3 (show lhs_tm) + let static_names = getStaticNames i lhs_tm + logLvl 5 (show lhs_tm ++ "\n" ++ show static_names) (clhs, clhsty) <- recheckC fc [] lhs_tm logLvl 5 ("Checked " ++ show clhs) let bargs = getPBtys (explicitNames (normalise ctxt [] lhs_tm)) @@ -745,7 +814,7 @@ (cwval, cwvalty) <- recheckC fc [] (getInferTerm wval') let cwvaltyN = explicitNames (normalise ctxt [] cwvalty) let cwvalN = explicitNames (normalise ctxt [] cwval) - logLvl 5 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty) + logLvl 3 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty) let pvars = map fst (getPBtys cwvalty) -- we need the unelaborated term to get the names it depends on -- rather than a de Bruijn index. @@ -769,7 +838,15 @@ let imps = getImps wtype -- add to implicits context putIState (i { idris_implicits = addDef wname imps (idris_implicits i) }) + let statics = getStatics static_names wtype + logLvl 5 ("Static positions " ++ show statics) + i <- getIState + putIState (i { idris_statics = addDef wname statics (idris_statics i) }) + addIBC (IBCDef wname) + addIBC (IBCImp wname) + addIBC (IBCStatic wname) + def' <- checkDef fc [(wname, (-1, Nothing, wtype))] let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def' addDeferred def'' @@ -867,5 +944,3 @@ split deps [] pre = (reverse pre, []) abstract wn wv wty (n, argty) = (n, substTerm wv (P Bound wn wty) argty) - - diff --git a/src/Idris/Elab/Data.hs b/src/Idris/Elab/Data.hs --- a/src/Idris/Elab/Data.hs +++ b/src/Idris/Elab/Data.hs @@ -20,6 +20,7 @@ import Idris.Elab.Type import Idris.Elab.Utils +import Idris.Elab.Value import Idris.Core.TT import Idris.Core.Elaborate hiding (Tactic(..)) @@ -49,7 +50,7 @@ import Util.Pretty(pretty, text) -elabData :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> FC -> DataOpts -> PData -> Idris () +elabData :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm)-> [(Name, Docstring (Either Err PTerm))] -> FC -> DataOpts -> PData -> Idris () elabData info syn doc argDocs fc opts (PLaterdecl n t_in) = do let codata = Codata `elem` opts iLOG (show (fc, doc)) @@ -77,7 +78,7 @@ cons <- mapM (elabCon cnameinfo syn n codata (getRetTy cty)) dcons ttag <- getName i <- getIState - let as = map (const Nothing) (getArgTys cty) + let as = map (const (Left (Msg ""))) (getArgTys cty) let params = findParams (map snd cons) logLvl 2 $ "Parameters : " ++ show params -- TI contains information about mutually declared types - this will @@ -88,7 +89,10 @@ addIBC (IBCDef n) addIBC (IBCData n) checkDocs fc argDocs t - addDocStr n doc argDocs + doc' <- elabDocTerms info doc + argDocs' <- mapM (\(n, d) -> do d' <- elabDocTerms info d + return (n, d')) argDocs + addDocStr n doc' argDocs' addIBC (IBCDoc n) let metainf = DataMI params addIBC (IBCMetaInformation n metainf) @@ -120,7 +124,7 @@ [oi] -> putIState ist{ idris_optimisation = addDef n oi{ detaggable = True } opt } _ -> putIState ist{ idris_optimisation = addDef n (Optimise [] True) opt } - checkDefinedAs fc n t ctxt + checkDefinedAs fc n t ctxt = case lookupDef n ctxt of [] -> return () [TyDecl _ ty] -> @@ -200,14 +204,9 @@ liftname = id -- Is this appropriate? } --- FIXME: 'forcenames' is an almighty hack! Need a better way of --- erasing non-forceable things --- ^^^ --- TODO: the above is a comment from the past; --- forcenames is probably no longer needed elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool -> Type -> -- for kind checking - (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> + (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name]) -> Idris (Name, Type) elabCon info syn tn codata expkind (doc, argDocs, n, t_in, fc, forcenames) = do checkUndefined fc n @@ -225,7 +224,10 @@ addIBC (IBCDef n) checkDocs fc argDocs t - addDocStr n doc argDocs + doc' <- elabDocTerms info doc + argDocs' <- mapM (\(n, d) -> do d' <- elabDocTerms info d + return (n, d')) argDocs + addDocStr n doc' argDocs' addIBC (IBCDoc n) fputState (opt_inaccessible . ist_optimisation n) inacc addIBC (IBCOpt n) @@ -237,7 +239,7 @@ else return () tyIs con t = tclift $ tfail (At fc (Elaborating "constructor " con (Msg (show t ++ " is not " ++ show tn)))) - mkLazy (PPi pl n ty sc) + mkLazy (PPi pl n ty sc) = let ty' = if getTyName ty then PApp fc (PRef fc (sUN "Lazy'")) [pexp (PRef fc (sUN "LazyCodata")), @@ -270,11 +272,14 @@ type EliminatorState = StateT (Map.Map String Int) Idris +-- -- Issue #1616 in the issue tracker. +-- https://github.com/idris-lang/Idris-dev/issues/1616 +-- -- TODO: Rewrite everything to use idris_implicits instead of manual splitting (or in TT) -- FIXME: Many things have name starting with elim internally since this was the only purpose in the first edition of the function -- rename to caseFun to match updated intend elabCaseFun :: Bool -> [Int] -> Name -> PTerm -> - [(Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name])] -> + [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name])] -> ElabInfo -> EliminatorState () elabCaseFun ind paramPos n ty cons info = do elimLog $ "Elaborating case function" @@ -293,7 +298,7 @@ let motiveConstr = [(motiveName, expl, motive)] let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0)) let eliminatorTy = piConstr (generalParams ++ motiveConstr ++ consTerms ++ scrutineeIdxs ++ [scrutinee]) (applyMotive (map (\(n,_,_) -> PRef elimFC n) scrutineeIdxs) (PRef elimFC scrutineeName)) - let eliminatorTyDecl = PTy (parseDocstring . T.pack $ show n) [] defaultSyntax elimFC [TotalFn] elimDeclName eliminatorTy + let eliminatorTyDecl = PTy (fmap (const (Left $ Msg "")) . parseDocstring . T.pack $ show n) [] defaultSyntax elimFC [TotalFn] elimDeclName eliminatorTy let clauseConsElimArgs = map getPiName consTerms let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs let clauseGeneralArgs = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs' @@ -410,7 +415,7 @@ case findIndex (== n) oldParams of Nothing -> (PPi pl n (removeParamPis oldParams params tyb) (removeParamPis oldParams params tyr)) Just i -> (removeParamPis oldParams params tyr) - removeParamPis oldParams params (PRef _ n) = + removeParamPis oldParams params (PRef _ n) = case findIndex (== n) oldParams of Nothing -> (PRef elimFC n) Just i -> let (newname,_,_) = params !! i in (PRef elimFC (newname)) @@ -443,7 +448,7 @@ splitArgPms _ = ([],[]) - implicitIndexes :: (Docstring, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)] + implicitIndexes :: (Docstring (Either Err PTerm), Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)] implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do i <- State.lift getIState implargs' <- case lookupCtxt cnm (idris_implicits i) of @@ -458,7 +463,7 @@ in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs _ -> return implargs - extractConsTerm :: (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm + extractConsTerm :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm extractConsTerm (doc, argDocs, cnm, ty, fc, fs) generalParameters = do let cons' = replaceParams paramPos generalParameters ty let (args, resTy) = splitPi cons' @@ -494,7 +499,7 @@ convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t) convertImplPi _ = Nothing - generateEliminatorClauses :: (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause + generateEliminatorClauses :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause generateEliminatorClauses (doc, _, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do let cons' = replaceParams paramPos generalParameters ty let (args, resTy) = splitPi cons' @@ -511,4 +516,3 @@ where applyRecElim :: (Name, Plicity, PTerm) -> PArg applyRecElim (constr@(recCnm,_,recTy)) = pexp $ PApp elimFC (PRef elimFC elimDeclName) (generalArgs ++ map pexp idxs ++ [pexp $ PRef elimFC recCnm]) where (_, idxs) = splitArgPms recTy - diff --git a/src/Idris/Elab/Instance.hs b/src/Idris/Elab/Instance.hs --- a/src/Idris/Elab/Instance.hs +++ b/src/Idris/Elab/Instance.hs @@ -63,7 +63,7 @@ (n, ci) <- case lookupCtxtName n (idris_classes i) of [c] -> return c [] -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class" - cs -> tclift $ tfail $ At fc + cs -> tclift $ tfail $ At fc (CantResolveAlts (map fst cs)) let constraint = PApp fc (PRef fc n) (map pexp ps) let iname = mkiname n ps expn @@ -77,7 +77,7 @@ (class_instances ci) addInstance intInst n iname Just _ -> addInstance intInst n iname - when (what /= ETypes && (not (null ds && not emptyclass))) $ do + when (what /= ETypes && (not (null ds && not emptyclass))) $ do let ips = zip (class_params ci) ps let ns = case n of NS n ns' -> ns' @@ -93,7 +93,7 @@ mapM_ (rec_elabDecl info EAll info) undefinedSuperclassInstances let all_meths = map (nsroot . fst) (class_methods ci) let mtys = map (\ (n, (op, t)) -> - let t_in = substMatchesShadow ips pnames t + let t_in = substMatchesShadow ips pnames t mnamemap = map (\n -> (n, PRef fc (decorate ns iname n))) all_meths t' = substMatchesShadow mnamemap pnames t_in in @@ -115,7 +115,7 @@ -- Bring variables in instance head into scope ist <- getIState let headVars = nub $ mapMaybe (\p -> case p of - PRef _ n -> + PRef _ n -> case lookupTy n (tt_ctxt ist) of [] -> Just n _ -> Nothing @@ -157,6 +157,8 @@ _ -> return False -- couldn't find class, just let elabInstance fail later -- TODO: largely based upon elabType' - should try to abstract + -- Issue #1614 in the issue tracker: + -- https://github.com/idris-lang/Idris-dev/issues/1614 elabFindOverlapping i ci iname syn t = do ty' <- addUsingConstraints syn fc t -- TODO think: something more in info? @@ -221,7 +223,8 @@ mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t - conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x) + conbind (ty : ns) x = PPi (constraint) -- { pstatic = Dynamic }) + (sMN 0 "class") ty (conbind ns x) conbind [] x = x coninsert cs (PPi p@(Imp _ _ _) n t sc) = PPi p n t (coninsert cs sc) @@ -256,5 +259,3 @@ clauseFor m iname ns (PClauses _ _ m' _) = decorate ns iname m == decorate ns iname m' clauseFor m iname ns _ = False - - diff --git a/src/Idris/Elab/Provider.hs b/src/Idris/Elab/Provider.hs --- a/src/Idris/Elab/Provider.hs +++ b/src/Idris/Elab/Provider.hs @@ -98,7 +98,7 @@ logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm | ProvPostulate _ <- what -> do -- Add the postulate - elabPostulate info syn (parseDocstring $ T.pack "Provided postulate") fc [] n (delab i tm) + elabPostulate info syn (fmap (const (Left $ Msg "")) . parseDocstring $ T.pack "Provided postulate") fc [] n (delab i tm) logLvl 3 $ "Elaborated provided postulate " ++ show n | otherwise -> ierror . Msg $ "Attempted to provide a postulate where a term was expected." diff --git a/src/Idris/Elab/Record.hs b/src/Idris/Elab/Record.hs --- a/src/Idris/Elab/Record.hs +++ b/src/Idris/Elab/Record.hs @@ -50,8 +50,8 @@ import Util.Pretty(pretty, text) -elabRecord :: ElabInfo -> SyntaxInfo -> Docstring -> FC -> Name -> - PTerm -> DataOpts -> Docstring -> Name -> PTerm -> Idris () +elabRecord :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> FC -> Name -> + PTerm -> DataOpts -> Docstring (Either Err PTerm) -> Name -> PTerm -> Idris () elabRecord info syn doc fc tyn ty opts cdoc cn cty_in = do elabData info syn doc [] fc opts (PDatadecl tyn ty [(cdoc, [], cn, cty_in, fc, [])]) -- TODO think: something more in info? diff --git a/src/Idris/Elab/Transform.hs b/src/Idris/Elab/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Elab/Transform.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE PatternGuards #-} +module Idris.Elab.Transform where + +import Idris.AbsSyntax +import Idris.ASTUtils +import Idris.DSL +import Idris.Error +import Idris.Delaborate +import Idris.Imports +import Idris.ElabTerm +import Idris.Coverage +import Idris.DataOpts +import Idris.Providers +import Idris.Primitives +import Idris.Inliner +import Idris.PartialEval +import Idris.DeepSeq +import Idris.Output (iputStrLn, pshow, iWarn) +import IRTS.Lang + +import Idris.Elab.Utils + +import Idris.Core.TT +import Idris.Core.Elaborate hiding (Tactic(..)) +import Idris.Core.Evaluate +import Idris.Core.Execute +import Idris.Core.Typecheck +import Idris.Core.CaseTree + +import Idris.Docstrings + +import Prelude hiding (id, (.)) +import Control.Category + +import Control.Applicative hiding (Const) +import Control.DeepSeq +import Control.Monad +import Control.Monad.State.Strict as State +import Data.List +import Data.Maybe +import Debug.Trace + +import qualified Data.Map as Map +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Char(isLetter, toLower) +import Data.List.Split (splitOn) + +import Util.Pretty(pretty, text) + +elabTransform :: ElabInfo -> FC -> Bool -> PTerm -> PTerm -> Idris (Term, Term) +elabTransform info fc safe lhs_in@(PApp _ (PRef _ tf) _) rhs_in + = do ctxt <- getContext + i <- getIState + let lhs = addImplPat i lhs_in + ((lhs', dlhs, []), _) <- + tclift $ elaborate ctxt (sMN 0 "transLHS") infP [] + (erun fc (buildTC i info ELHS [] (sUN "transform") + (infTerm lhs))) + let lhs_tm = orderPats (getInferTerm lhs') + let lhs_ty = getInferType lhs' + let newargs = pvars i lhs_tm + + (clhs_tm, clhs_ty) <- recheckC fc [] lhs_tm + logLvl 3 ("Transform LHS " ++ show clhs_tm) + let rhs = addImplBound i (map fst newargs) rhs_in + ((rhs', defer), _) <- + tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty [] + (do pbinds i lhs_tm + setNextName + erun fc (build i info ERHS [] (sUN "transform") rhs) + erun fc $ psolve lhs_tm + tt <- get_term + return (runState (collectDeferred Nothing tt) [])) + (crhs_tm, crhs_ty) <- recheckC fc [] rhs' + logLvl 3 ("Transform RHS " ++ show crhs_tm) + -- Types must always convert + case converts ctxt [] clhs_ty crhs_ty of + OK _ -> return () + Error e -> ierror (At fc (CantUnify False clhs_tm crhs_tm e [] 0)) + -- In safe mode, values must convert (Thinks: This is probably not + -- useful as is, perhaps it should require a proof of equality instead) + when safe $ case converts ctxt [] clhs_tm crhs_tm of + OK _ -> return () + Error e -> ierror (At fc (CantUnify False clhs_tm crhs_tm e [] 0)) + + case unApply (depat clhs_tm) of + (P _ tfname _, _) -> do addTrans tfname (clhs_tm, crhs_tm) + addIBC (IBCTrans tf (clhs_tm, crhs_tm)) + _ -> ierror (At fc (Msg "Invalid transformation rule (must be function application)")) + return (clhs_tm, crhs_tm) + + where + depat (Bind n (PVar t) sc) = depat (instantiate (P Bound n t) sc) + depat x = x + +elabTransform info fc safe lhs_in rhs_in + = ierror (At fc (Msg "Invalid transformation rule (must be function application)")) + diff --git a/src/Idris/Elab/Type.hs b/src/Idris/Elab/Type.hs --- a/src/Idris/Elab/Type.hs +++ b/src/Idris/Elab/Type.hs @@ -1,5 +1,5 @@ {-# LANGUAGE PatternGuards #-} -module Idris.Elab.Type(buildType, elabType, elabType', elabPostulate) where +module Idris.Elab.Type (buildType, elabType, elabType', elabPostulate) where import Idris.AbsSyntax import Idris.ASTUtils @@ -19,6 +19,7 @@ import IRTS.Lang import Idris.Elab.Utils +import Idris.Elab.Value import Idris.Core.TT import Idris.Core.Elaborate hiding (Tactic(..)) @@ -27,7 +28,7 @@ import Idris.Core.Typecheck import Idris.Core.CaseTree -import Idris.Docstrings +import Idris.Docstrings (Docstring) import Prelude hiding (id, (.)) import Control.Category @@ -40,6 +41,8 @@ import Data.Maybe import Debug.Trace +import qualified Data.Traversable as Traversable + import qualified Data.Map as Map import qualified Data.Set as S import qualified Data.Text as T @@ -111,12 +114,12 @@ param_pos i ns t = [] -- | Elaborate a top-level type declaration - for example, "foo : Int -> Int". -elabType :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> +elabType :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm)-> [(Name, Docstring (Either Err PTerm))] -> FC -> FnOpts -> Name -> PTerm -> Idris Type elabType = elabType' False elabType' :: Bool -> -- normalise it - ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> + ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] -> FC -> FnOpts -> Name -> PTerm -> Idris Type elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in n = liftname info n_in in -} @@ -127,6 +130,7 @@ let nty = cty -- normalise ctxt [] cty -- if the return type is something coinductive, freeze the definition ctxt <- getContext + logLvl 2 $ "Rechecked to " ++ show nty let nty' = normalise ctxt [] nty logLvl 2 $ "Rechecked to " ++ show nty' @@ -152,7 +156,10 @@ addDeferred ds' setFlags n opts' checkDocs fc argDocs ty - addDocStr n doc argDocs + doc' <- elabDocTerms info doc + argDocs' <- mapM (\(n, d) -> do d' <- elabDocTerms info d + return (n, d')) argDocs + addDocStr n doc' argDocs' addIBC (IBCDoc n) addIBC (IBCFlags n opts') fputState (opt_inaccessible . ist_optimisation n) inacc @@ -166,7 +173,7 @@ when (ErrorHandler `elem` opts) $ do if errorReflection then - -- TODO: Check that the declared type is the correct type for an error handler: + -- Check that the declared type is the correct type for an error handler: -- handler : List (TTName, TT) -> Err -> ErrorReport - for now no ctxt if tyIsHandler nty' then do i <- getIState @@ -200,7 +207,7 @@ , ns4 == map txt ["Reflection","Language"] = True tyIsHandler _ = False -elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring -> +elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> FC -> FnOpts -> Name -> PTerm -> Idris () elabPostulate info syn doc fc opts n ty = do elabType info syn doc [] fc opts n ty @@ -209,3 +216,6 @@ -- remove it from the deferred definitions list solveDeferred n + + + diff --git a/src/Idris/Elab/Utils.hs b/src/Idris/Elab/Utils.hs --- a/src/Idris/Elab/Utils.hs +++ b/src/Idris/Elab/Utils.hs @@ -16,6 +16,7 @@ import Control.Monad.State import Control.Monad import Data.List +import qualified Data.Traversable as Traversable import Debug.Trace @@ -105,7 +106,7 @@ -- | Check a PTerm against documentation and ensure that every documented -- argument actually exists. This must be run _after_ implicits have been -- found, or it will give spurious errors. -checkDocs :: FC -> [(Name, Docstring)] -> PTerm -> Idris () +checkDocs :: FC -> [(Name, Docstring a)] -> PTerm -> Idris () checkDocs fc args tm = cd (Map.fromList args) tm where cd as (PPi _ n _ sc) = cd (Map.delete n as) sc cd as _ | Map.null as = return () @@ -233,6 +234,39 @@ getUniqB env us (Pi t v) = do getUniq env us t; getUniq env us v getUniqB env us (NLet t v) = do getUniq env us t; getUniq env us v getUniqB env us b = getUniq env us (binderTy b) + +-- In a functional application, return the names which are used +-- directly in a static position +getStaticNames :: IState -> Term -> [Name] +getStaticNames ist (Bind n (PVar _) sc) + = getStaticNames ist (instantiate (P Bound n Erased) sc) +getStaticNames ist tm + | (P _ fn _, args) <- unApply tm + = case lookupCtxtExact fn (idris_statics ist) of + Just stpos -> getStatics args stpos + _ -> [] + where + getStatics (P _ n _ : as) (True : ss) = n : getStatics as ss + getStatics (_ : as) (_ : ss) = getStatics as ss + getStatics _ _ = [] +getStaticNames _ _ = [] + +getStatics :: [Name] -> Term -> [Bool] +getStatics ns (Bind n (Pi _ _) t) + | n `elem` ns = True : getStatics ns t + | otherwise = False : getStatics ns t +getStatics _ _ = [] + +mkStatic :: [Name] -> PDecl -> PDecl +mkStatic ns (PTy doc argdocs syn fc o n ty) + = PTy doc argdocs syn fc o n (mkStaticTy ns ty) +mkStatic ns t = t + +mkStaticTy :: [Name] -> PTerm -> PTerm +mkStaticTy ns (PPi p n ty sc) + | n `elem` ns = PPi (p { pstatic = Static }) n ty (mkStaticTy ns sc) + | otherwise = PPi p n ty (mkStaticTy ns sc) +mkStaticTy ns t = t diff --git a/src/Idris/Elab/Value.hs b/src/Idris/Elab/Value.hs --- a/src/Idris/Elab/Value.hs +++ b/src/Idris/Elab/Value.hs @@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-} -module Idris.Elab.Value(elabVal, elabValBind) where +{-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-} +module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms) where import Idris.AbsSyntax import Idris.ASTUtils @@ -22,7 +23,7 @@ import Idris.Core.TT import Idris.Core.Elaborate hiding (Tactic(..)) -import Idris.Core.Evaluate +import Idris.Core.Evaluate hiding (Unchecked) import Idris.Core.Execute import Idris.Core.Typecheck import Idris.Core.CaseTree @@ -38,6 +39,7 @@ import Control.Monad.State.Strict as State import Data.List import Data.Maybe +import qualified Data.Traversable as Traversable import Debug.Trace import qualified Data.Map as Map @@ -86,3 +88,24 @@ return (tm, ty) + +elabDocTerms :: ElabInfo -> Docstring (Either Err PTerm) -> Idris (Docstring DocTerm) +elabDocTerms info str = do typechecked <- Traversable.mapM decorate str + return $ checkDocstring mkDocTerm typechecked + where decorate (Left err) = return (Left err) + decorate (Right pt) = fmap (fmap fst) (tryElabVal info ERHS pt) + + tryElabVal :: ElabInfo -> ElabMode -> PTerm -> Idris (Either Err (Term, Type)) + tryElabVal info aspat tm_in + = idrisCatch (fmap Right $ elabVal info aspat tm_in) + (return . Left) + + mkDocTerm :: String -> [String] -> String -> Either Err Term -> DocTerm + mkDocTerm lang attrs src (Left err) + | map toLower lang == "idris" = Failing err + | otherwise = Unchecked + mkDocTerm lang attrs src (Right tm) + | map toLower lang == "idris" = if "example" `elem` map (map toLower) attrs + then Example tm + else Checked tm + | otherwise = Unchecked diff --git a/src/Idris/ElabDecls.hs b/src/Idris/ElabDecls.hs --- a/src/Idris/ElabDecls.hs +++ b/src/Idris/ElabDecls.hs @@ -28,6 +28,7 @@ import Idris.Elab.Class import Idris.Elab.Instance import Idris.Elab.Provider +import Idris.Elab.Transform import Idris.Elab.Value import Idris.Core.TT @@ -37,7 +38,7 @@ import Idris.Core.Typecheck import Idris.Core.CaseTree -import Idris.Docstrings +import Idris.Docstrings hiding (Unchecked) import Prelude hiding (id, (.)) import Control.Category @@ -76,12 +77,11 @@ elabPrims = do mapM_ (elabDecl' EAll recinfo) (map (\(opt, decl, docs, argdocs) -> PData docs argdocs defaultSyntax (fileFC "builtin") opt decl) (zip4 - [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts] - [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl] - [emptyDocstring, unitDoc, falseDoc, pairDoc, eqDoc] - [[], [], [], pairParamDoc, eqParamDoc])) + [inferOpts, eqOpts] + [inferDecl, eqDecl] + [emptyDocstring, eqDoc] + [[], eqParamDoc])) addNameHint eqTy (sUN "prf") - elabDecl' EAll recinfo elimDecl mapM_ elabPrim primitives -- Special case prim__believe_me because it doesn't work on just constants elabBelieveMe @@ -142,38 +142,7 @@ idris_scprims = (synEq, (4, LNoOp)) : idris_scprims i } -elabTransform :: ElabInfo -> FC -> Bool -> PTerm -> PTerm -> Idris () -elabTransform info fc safe lhs_in rhs_in - = do ctxt <- getContext - i <- getIState - let lhs = addImplPat i lhs_in - ((lhs', dlhs, []), _) <- - tclift $ elaborate ctxt (sMN 0 "transLHS") infP [] - (erun fc (buildTC i info ELHS [] (sUN "transform") - (infTerm lhs))) - let lhs_tm = orderPats (getInferTerm lhs') - let lhs_ty = getInferType lhs' - let newargs = pvars i lhs_tm - (clhs_tm, clhs_ty) <- recheckC fc [] lhs_tm - logLvl 3 ("Transform LHS " ++ show clhs_tm) - let rhs = addImplBound i (map fst newargs) rhs_in - ((rhs', defer), _) <- - tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty [] - (do pbinds i lhs_tm - setNextName - erun fc (build i info ERHS [] (sUN "transform") rhs) - erun fc $ psolve lhs_tm - tt <- get_term - return (runState (collectDeferred Nothing tt) [])) - (crhs_tm, crhs_ty) <- recheckC fc [] rhs' - logLvl 3 ("Transform RHS " ++ show crhs_tm) - when safe $ case converts ctxt [] clhs_tm crhs_tm of - OK _ -> return () - Error e -> ierror (At fc (CantUnify False clhs_tm crhs_tm e [] 0)) - addTrans (clhs_tm, crhs_tm) - addIBC (IBCTrans (clhs_tm, crhs_tm)) - elabDecls :: ElabInfo -> [PDecl] -> Idris () elabDecls info ds = do mapM_ (elabDecl EAll info) ds @@ -285,6 +254,7 @@ = do iLOG $ "Elaborating type provider " ++ show n elabProvider info syn fc provWhat n elabDecl' what info (PTransform fc safety old new) - = elabTransform info fc safety old new + = do elabTransform info fc safety old new + return () elabDecl' _ _ _ = return () -- skipped this time diff --git a/src/Idris/ElabQuasiquote.hs b/src/Idris/ElabQuasiquote.hs --- a/src/Idris/ElabQuasiquote.hs +++ b/src/Idris/ElabQuasiquote.hs @@ -5,167 +5,170 @@ import Idris.AbsSyntax -extract1 :: (PTerm -> a) -> PTerm -> Elab' aux (a, [(Name, PTerm)]) -extract1 c tm = do (tm', ex) <- extractUnquotes tm - return (c tm', ex) +extract1 :: Int -> (PTerm -> a) -> PTerm -> Elab' aux (a, [(Name, PTerm)]) +extract1 n c tm = do (tm', ex) <- extractUnquotes n tm + return (c tm', ex) -extract2 :: (PTerm -> PTerm -> a) -> PTerm -> PTerm -> Elab' aux (a, [(Name, PTerm)]) -extract2 c a b = do (a', ex1) <- extractUnquotes a - (b', ex2) <- extractUnquotes b - return (c a' b', ex1 ++ ex2) +extract2 :: Int -> (PTerm -> PTerm -> a) -> PTerm -> PTerm -> Elab' aux (a, [(Name, PTerm)]) +extract2 n c a b = do (a', ex1) <- extractUnquotes n a + (b', ex2) <- extractUnquotes n b + return (c a' b', ex1 ++ ex2) -extractTUnquotes :: PTactic -> Elab' aux (PTactic, [(Name, PTerm)]) -extractTUnquotes (Rewrite t) = extract1 Rewrite t -extractTUnquotes (Induction t) = extract1 Induction t -extractTUnquotes (LetTac n t) = extract1 (LetTac n) t -extractTUnquotes (LetTacTy n t1 t2) = extract2 (LetTacTy n) t1 t2 -extractTUnquotes (Exact tm) = extract1 Exact tm -extractTUnquotes (Try tac1 tac2) - = do (tac1', ex1) <- extractTUnquotes tac1 - (tac2', ex2) <- extractTUnquotes tac2 +extractTUnquotes :: Int -> PTactic -> Elab' aux (PTactic, [(Name, PTerm)]) +extractTUnquotes n (Rewrite t) = extract1 n Rewrite t +extractTUnquotes n (Induction t) = extract1 n Induction t +extractTUnquotes n (LetTac name t) = extract1 n (LetTac name) t +extractTUnquotes n (LetTacTy name t1 t2) = extract2 n (LetTacTy name) t1 t2 +extractTUnquotes n (Exact tm) = extract1 n Exact tm +extractTUnquotes n (Try tac1 tac2) + = do (tac1', ex1) <- extractTUnquotes n tac1 + (tac2', ex2) <- extractTUnquotes n tac2 return (Try tac1' tac2', ex1 ++ ex2) -extractTUnquotes (TSeq tac1 tac2) - = do (tac1', ex1) <- extractTUnquotes tac1 - (tac2', ex2) <- extractTUnquotes tac2 +extractTUnquotes n (TSeq tac1 tac2) + = do (tac1', ex1) <- extractTUnquotes n tac1 + (tac2', ex2) <- extractTUnquotes n tac2 return (TSeq tac1' tac2', ex1 ++ ex2) -extractTUnquotes (ApplyTactic t) = extract1 ApplyTactic t -extractTUnquotes (ByReflection t) = extract1 ByReflection t -extractTUnquotes (Reflect t) = extract1 Reflect t -extractTUnquotes (GoalType s tac) - = do (tac', ex) <- extractTUnquotes tac +extractTUnquotes n (ApplyTactic t) = extract1 n ApplyTactic t +extractTUnquotes n (ByReflection t) = extract1 n ByReflection t +extractTUnquotes n (Reflect t) = extract1 n Reflect t +extractTUnquotes n (GoalType s tac) + = do (tac', ex) <- extractTUnquotes n tac return (GoalType s tac', ex) -extractTUnquotes (TCheck t) = extract1 TCheck t -extractTUnquotes (TEval t) = extract1 TEval t -extractTUnquotes tac = return (tac, []) -- the rest don't contain PTerms +extractTUnquotes n (TCheck t) = extract1 n TCheck t +extractTUnquotes n (TEval t) = extract1 n TEval t +extractTUnquotes n tac = return (tac, []) -- the rest don't contain PTerms -extractPArgUnquotes :: PArg -> Elab' aux (PArg, [(Name, PTerm)]) -extractPArgUnquotes (PImp p m opts n t) = - do (t', ex) <- extractUnquotes t +extractPArgUnquotes :: Int -> PArg -> Elab' aux (PArg, [(Name, PTerm)]) +extractPArgUnquotes d (PImp p m opts n t) = + do (t', ex) <- extractUnquotes d t return (PImp p m opts n t', ex) -extractPArgUnquotes (PExp p opts n t) = - do (t', ex) <- extractUnquotes t +extractPArgUnquotes d (PExp p opts n t) = + do (t', ex) <- extractUnquotes d t return (PExp p opts n t', ex) -extractPArgUnquotes (PConstraint p opts n t) = - do (t', ex) <- extractUnquotes t +extractPArgUnquotes d (PConstraint p opts n t) = + do (t', ex) <- extractUnquotes d t return (PConstraint p opts n t', ex) -extractPArgUnquotes (PTacImplicit p opts n scpt t) = - do (scpt', ex1) <- extractUnquotes scpt - (t', ex2) <- extractUnquotes t +extractPArgUnquotes d (PTacImplicit p opts n scpt t) = + do (scpt', ex1) <- extractUnquotes d scpt + (t', ex2) <- extractUnquotes d t return (PTacImplicit p opts n scpt' t', ex1 ++ ex2) -extractDoUnquotes :: PDo -> Elab' aux (PDo, [(Name, PTerm)]) -extractDoUnquotes (DoExp fc tm) - = do (tm', ex) <- extractUnquotes tm +extractDoUnquotes :: Int -> PDo -> Elab' aux (PDo, [(Name, PTerm)]) +extractDoUnquotes d (DoExp fc tm) + = do (tm', ex) <- extractUnquotes d tm return (DoExp fc tm', ex) -extractDoUnquotes (DoBind fc n tm) - = do (tm', ex) <- extractUnquotes tm +extractDoUnquotes d (DoBind fc n tm) + = do (tm', ex) <- extractUnquotes d tm return (DoBind fc n tm', ex) -extractDoUnquotes (DoBindP fc t t' alts) +extractDoUnquotes d (DoBindP fc t t' alts) = fail "Pattern-matching binds cannot be quasiquoted" -extractDoUnquotes (DoLet fc n v b) - = do (v', ex1) <- extractUnquotes v - (b', ex2) <- extractUnquotes b +extractDoUnquotes d (DoLet fc n v b) + = do (v', ex1) <- extractUnquotes d v + (b', ex2) <- extractUnquotes d b return (DoLet fc n v' b', ex1 ++ ex2) -extractDoUnquotes (DoLetP fc t t') = fail "Pattern-matching lets cannot be quasiquoted" +extractDoUnquotes d (DoLetP fc t t') = fail "Pattern-matching lets cannot be quasiquoted" -extractUnquotes :: PTerm -> Elab' aux (PTerm, [(Name, PTerm)]) -extractUnquotes (PLam n ty body) - = do (ty', ex1) <- extractUnquotes ty - (body', ex2) <- extractUnquotes body - return (PLam n ty' body', ex1 ++ ex2) -extractUnquotes (PPi plicity n ty body) - = do (ty', ex1) <- extractUnquotes ty - (body', ex2) <- extractUnquotes body - return (PPi plicity n ty' body', ex1 ++ ex2) -extractUnquotes (PLet n ty val body) - = do (ty', ex1) <- extractUnquotes ty - (val', ex2) <- extractUnquotes val - (body', ex3) <- extractUnquotes body - return (PLet n ty' val' body', ex1 ++ ex2 ++ ex3) -extractUnquotes (PTyped tm ty) - = do (tm', ex1) <- extractUnquotes tm - (ty', ex2) <- extractUnquotes ty +extractUnquotes :: Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)]) +extractUnquotes n (PLam name ty body) + = do (ty', ex1) <- extractUnquotes n ty + (body', ex2) <- extractUnquotes n body + return (PLam name ty' body', ex1 ++ ex2) +extractUnquotes n (PPi plicity name ty body) + = do (ty', ex1) <- extractUnquotes n ty + (body', ex2) <- extractUnquotes n body + return (PPi plicity name ty' body', ex1 ++ ex2) +extractUnquotes n (PLet name ty val body) + = do (ty', ex1) <- extractUnquotes n ty + (val', ex2) <- extractUnquotes n val + (body', ex3) <- extractUnquotes n body + return (PLet name ty' val' body', ex1 ++ ex2 ++ ex3) +extractUnquotes n (PTyped tm ty) + = do (tm', ex1) <- extractUnquotes n tm + (ty', ex2) <- extractUnquotes n ty return (PTyped tm' ty', ex1 ++ ex2) -extractUnquotes (PApp fc f args) - = do (f', ex1) <- extractUnquotes f - args' <- mapM extractPArgUnquotes args +extractUnquotes n (PApp fc f args) + = do (f', ex1) <- extractUnquotes n f + args' <- mapM (extractPArgUnquotes n) args let (args'', exs) = unzip args' return (PApp fc f' args'', ex1 ++ concat exs) -extractUnquotes (PAppBind fc f args) - = do (f', ex1) <- extractUnquotes f - args' <- mapM extractPArgUnquotes args +extractUnquotes n (PAppBind fc f args) + = do (f', ex1) <- extractUnquotes n f + args' <- mapM (extractPArgUnquotes n) args let (args'', exs) = unzip args' return (PAppBind fc f' args'', ex1 ++ concat exs) -extractUnquotes (PCase fc expr cases) - = do (expr', ex1) <- extractUnquotes expr +extractUnquotes n (PCase fc expr cases) + = do (expr', ex1) <- extractUnquotes n expr let (pats, rhss) = unzip cases - (pats', exs1) <- fmap unzip $ mapM extractUnquotes pats - (rhss', exs2) <- fmap unzip $ mapM extractUnquotes rhss + (pats', exs1) <- fmap unzip $ mapM (extractUnquotes n) pats + (rhss', exs2) <- fmap unzip $ mapM (extractUnquotes n) rhss return (PCase fc expr' (zip pats' rhss'), ex1 ++ concat exs1 ++ concat exs2) -extractUnquotes (PRefl fc x) - = do (x', ex) <- extractUnquotes x +extractUnquotes n (PRefl fc x) + = do (x', ex) <- extractUnquotes n x return (PRefl fc x', ex) -extractUnquotes (PEq fc at bt a b) - = do (at', ex1) <- extractUnquotes at - (bt', ex2) <- extractUnquotes bt - (a', ex1) <- extractUnquotes a - (b', ex2) <- extractUnquotes b +extractUnquotes n (PEq fc at bt a b) + = do (at', ex1) <- extractUnquotes n at + (bt', ex2) <- extractUnquotes n bt + (a', ex1) <- extractUnquotes n a + (b', ex2) <- extractUnquotes n b return (PEq fc at' bt' a' b', ex1 ++ ex2) -extractUnquotes (PRewrite fc x y z) - = do (x', ex1) <- extractUnquotes x - (y', ex2) <- extractUnquotes y +extractUnquotes n (PRewrite fc x y z) + = do (x', ex1) <- extractUnquotes n x + (y', ex2) <- extractUnquotes n y case z of - Just zz -> do (z', ex3) <- extractUnquotes zz + Just zz -> do (z', ex3) <- extractUnquotes n zz return (PRewrite fc x' y' (Just z'), ex1 ++ ex2 ++ ex3) Nothing -> return (PRewrite fc x' y' Nothing, ex1 ++ ex2) -extractUnquotes (PPair fc info l r) - = do (l', ex1) <- extractUnquotes l - (r', ex2) <- extractUnquotes r +extractUnquotes n (PPair fc info l r) + = do (l', ex1) <- extractUnquotes n l + (r', ex2) <- extractUnquotes n r return (PPair fc info l' r', ex1 ++ ex2) -extractUnquotes (PDPair fc info a b c) - = do (a', ex1) <- extractUnquotes a - (b', ex2) <- extractUnquotes b - (c', ex3) <- extractUnquotes c +extractUnquotes n (PDPair fc info a b c) + = do (a', ex1) <- extractUnquotes n a + (b', ex2) <- extractUnquotes n b + (c', ex3) <- extractUnquotes n c return (PDPair fc info a' b' c', ex1 ++ ex2 ++ ex3) -extractUnquotes (PAlternative b alts) - = do alts' <- mapM extractUnquotes alts +extractUnquotes n (PAlternative b alts) + = do alts' <- mapM (extractUnquotes n) alts let (alts'', exs) = unzip alts' return (PAlternative b alts'', concat exs) -extractUnquotes (PHidden tm) - = do (tm', ex) <- extractUnquotes tm +extractUnquotes n (PHidden tm) + = do (tm', ex) <- extractUnquotes n tm return (PHidden tm', ex) -extractUnquotes (PGoal fc a n b) - = do (a', ex1) <- extractUnquotes a - (b', ex2) <- extractUnquotes b - return (PGoal fc a' n b', ex1 ++ ex2) -extractUnquotes (PDoBlock steps) - = do steps' <- mapM extractDoUnquotes steps +extractUnquotes n (PGoal fc a name b) + = do (a', ex1) <- extractUnquotes n a + (b', ex2) <- extractUnquotes n b + return (PGoal fc a' name b', ex1 ++ ex2) +extractUnquotes n (PDoBlock steps) + = do steps' <- mapM (extractDoUnquotes n) steps let (steps'', exs) = unzip steps' return (PDoBlock steps'', concat exs) -extractUnquotes (PIdiom fc tm) - = fmap (\(tm', ex) -> (PIdiom fc tm', ex)) $ extractUnquotes tm -extractUnquotes (PProof tacs) - = do (tacs', exs) <- fmap unzip $ mapM extractTUnquotes tacs +extractUnquotes n (PIdiom fc tm) + = fmap (\(tm', ex) -> (PIdiom fc tm', ex)) $ extractUnquotes n tm +extractUnquotes n (PProof tacs) + = do (tacs', exs) <- fmap unzip $ mapM (extractTUnquotes n) tacs return (PProof tacs', concat exs) -extractUnquotes (PTactics tacs) - = do (tacs', exs) <- fmap unzip $ mapM extractTUnquotes tacs +extractUnquotes n (PTactics tacs) + = do (tacs', exs) <- fmap unzip $ mapM (extractTUnquotes n) tacs return (PTactics tacs', concat exs) -extractUnquotes (PElabError err) = fail "Can't quasiquote an error" -extractUnquotes (PCoerced tm) - = do (tm', ex) <- extractUnquotes tm +extractUnquotes n (PElabError err) = fail "Can't quasiquote an error" +extractUnquotes n (PCoerced tm) + = do (tm', ex) <- extractUnquotes n tm return (PCoerced tm', ex) -extractUnquotes (PDisamb ns tm) - = do (tm', ex) <- extractUnquotes tm +extractUnquotes n (PDisamb ns tm) + = do (tm', ex) <- extractUnquotes n tm return (PDisamb ns tm', ex) -extractUnquotes (PUnifyLog tm) - = fmap (\(tm', ex) -> (PUnifyLog tm', ex)) $ extractUnquotes tm -extractUnquotes (PNoImplicits tm) - = fmap (\(tm', ex) -> (PNoImplicits tm', ex)) $ extractUnquotes tm -extractUnquotes (PQuasiquote _ _) = fail "Nested quasiquotes not supported" -extractUnquotes (PUnquote tm) = - do n <- getNameFrom (sMN 0 "unquotation") - return (PRef (fileFC "(unquote)") n, [(n, tm)]) -extractUnquotes x = return (x, []) -- no subterms! +extractUnquotes n (PUnifyLog tm) + = fmap (\(tm', ex) -> (PUnifyLog tm', ex)) $ extractUnquotes n tm +extractUnquotes n (PNoImplicits tm) + = fmap (\(tm', ex) -> (PNoImplicits tm', ex)) $ extractUnquotes n tm +extractUnquotes n (PQuasiquote tm goal) + = fmap (\(tm', ex) -> (PQuasiquote tm' goal, ex)) $ extractUnquotes (n+1) tm +extractUnquotes n (PUnquote tm) + | n == 0 = do n <- getNameFrom (sMN 0 "unquotation") + return (PRef (fileFC "(unquote)") n, [(n, tm)]) + | otherwise = fmap (\(tm', ex) -> (PUnquote tm', ex)) $ + extractUnquotes (n-1) tm +extractUnquotes n x = return (x, []) -- no subterms! diff --git a/src/Idris/ElabTerm.hs b/src/Idris/ElabTerm.hs --- a/src/Idris/ElabTerm.hs +++ b/src/Idris/ElabTerm.hs @@ -18,7 +18,7 @@ import Idris.ErrReverse (errReverse) import Idris.ElabQuasiquote (extractUnquotes) import Idris.Elab.Utils -import qualified Util.Pretty as U +import qualified Util.Pretty as U import Control.Applicative ((<$>)) import Control.Monad @@ -76,9 +76,9 @@ u <- getUnifyLog hs <- get_holes - when (not pattern) $ + when (not pattern) $ traceWhen u ("Remaining holes:\n" ++ show hs ++ "\n" ++ - "Remaining problems:\n" ++ qshow probs) $ + "Remaining problems:\n" ++ qshow probs) $ do unify_all; matchProblems True; unifyProblems probs <- get_probs @@ -99,7 +99,7 @@ else return (tm, ds, is) where pattern = emode == ELHS tydecl = emode == ETyDecl - + mkPat = do hs <- get_holes tm <- get_term case hs of @@ -197,14 +197,14 @@ -- ++ "\nholes " ++ show hs -- ++ "\nproblems " ++ show ps -- ++ "\n-----------\n") $ - --trace ("ELAB " ++ show t') $ + --trace ("ELAB " ++ show t') $ let fc = fileFC "Force" env <- get_env handleError (forceErr env) (elab' ina t') (elab' ina (PApp fc (PRef fc (sUN "Force")) [pimp (sUN "t") Placeholder True, - pimp (sUN "a") Placeholder True, + pimp (sUN "a") Placeholder True, pexp ct])) True forceErr env (CantUnify _ t t' _ _ _) @@ -240,14 +240,17 @@ elab' ina (PNoImplicits t) = elab' ina t -- skip elabE step elab' ina PType = do apply RType []; solve elab' ina (PUniverse u) = do apply (RUType u) []; solve --- elab' (_,_,inty) (PConstant c) +-- elab' (_,_,inty) (PConstant c) -- | constType c && pattern && not reflection && not inty --- = lift $ tfail (Msg "Typecase is not allowed") +-- = lift $ tfail (Msg "Typecase is not allowed") elab' ina (PConstant c) = do apply (RConstant c) []; solve elab' ina (PQuote r) = do fill r; solve - elab' ina (PTrue fc _) = try (elab' ina (PRef fc unitCon)) - (elab' ina (PRef fc unitTy)) - elab' ina (PFalse fc) = elab' ina (PRef fc falseTy) + elab' ina (PTrue fc _) = + do hnf_compute + g <- goal + case g of + TType _ -> elab' ina (PRef fc unitTy) + _ -> elab' ina (PRef fc unitCon) elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes = do g <- goal; resolveTC False 5 g fn ist elab' ina (PResolveTC fc) @@ -283,11 +286,11 @@ = do hnf_compute g <- goal case g of - TType _ -> elabE (True, a,inty, qq) (PApp fc (PRef fc pairTy) + TType _ -> elab' ina (PApp fc (PRef fc pairTy) [pexp l,pexp r]) - _ -> elabE (True, a, inty, qq) (PApp fc (PRef fc pairCon) - [pimp (sMN 0 "A") Placeholder True, - pimp (sMN 0 "B") Placeholder True, + _ -> elab' ina (PApp fc (PRef fc pairCon) + [pimp (sUN "A") Placeholder False, + pimp (sUN "B") Placeholder False, pexp l, pexp r]) elab' ina (PDPair fc p l@(PRef _ n) t r) = case t of @@ -316,7 +319,9 @@ let (tc, _) = unApply ty env <- get_env let as' = pruneByType (map fst env) tc ctxt as --- trace (show as ++ "\n ==> " ++ showSep ", " (map showTmImpls as')) $ +-- trace (-- show tc ++ " " ++ show as ++ "\n ==> " ++ +-- show (length as') ++ "\n" ++ +-- showSep ", " (map showTmImpls as') ++ "\nEND") $ tryAll (zip (map (elab' ina) as') (map showHd as')) where showHd (PApp _ (PRef _ n) _) = n showHd (PRef _ n) = n @@ -334,7 +339,7 @@ -- elab' (_, _, inty) (PRef fc f) -- | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty -- = lift $ tfail (Msg "Typecase is not allowed") - elab' (ina, guarded, inty, qq) (PRef fc n) + elab' (ina, guarded, inty, qq) (PRef fc n) | (pattern || (bindfree && bindable n)) && not (inparamBlock n) && not qq = do ctxt <- get_context let defined = case lookupTy n ctxt of @@ -359,7 +364,7 @@ = do -- if n is a type constructor name, this makes no sense... ctxt <- get_context when (isTConName n ctxt) $ - lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here") + lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here") checkPiGoal n attack; intro (Just n); -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm) @@ -369,7 +374,7 @@ -- if n is a type constructor name, this makes no sense... ctxt <- get_context when (isTConName n ctxt) $ - lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here") + lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here") checkPiGoal n claim tyn RType explicit tyn @@ -496,9 +501,11 @@ _ -> lift $ tfail (NoSuchVariable fn) ns <- match_apply (Var fn') (map (\x -> (x,0)) imps) solve - elab' (_, _, inty, qq) (PApp fc (PRef _ f) args') - | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty && not qq - = lift $ tfail (Msg "Typecase is not allowed") + -- This isn't a sound way of checking for Typecase - we need a + -- better way! +-- elab' (_, _, inty, qq) (PApp fc (PRef _ f) args') +-- | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty && not qq +-- = lift $ tfail (Msg "Typecase is not allowed") -- if f is local, just do a simple_app elab' (ina, g, inty, qq) tm@(PApp fc (PRef _ f) args) = do env <- get_env @@ -535,7 +542,7 @@ sortBy cmpArg (zip ns args) ulog <- getUnifyLog elabArgs ist (ina || not isinf, guarded, inty, qq) - [] fc False f ns' + [] fc False f ns' (f == sUN "Force") (map (\x -> getTm x) eargs) -- TODO: remove this False arg solve @@ -554,7 +561,7 @@ else movelast n) (ivs' \\ ivs) where -- normal < alternatives < lambdas < rewrites < tactic < default tactic - -- reason for lambdas after alternatives is that having + -- reason for lambdas after alternatives is that having -- the alternative resolved can help with typechecking the lambda -- or the rewrite. Rewrites/tactics need as much information -- as possible about the type. @@ -564,7 +571,7 @@ | constraint x && not (constraint y) = LT | constraint y && not (constraint x) = GT | otherwise - = compare (conDepth 0 (getTm x) + priority x + alt x) + = compare (conDepth 0 (getTm x) + priority x + alt x) (conDepth 0 (getTm y) + priority y + alt y) where alt t = case getTm t of PAlternative False _ -> 5 @@ -577,14 +584,14 @@ constraint (PConstraint _ _ _ _) = True constraint _ = False - + -- Score a point for every level where there is a non-constructor -- function (so higher score --> done later) -- Only relevant when on lhs conDepth d t | not pattern = 0 conDepth d (PRef _ f) | isConName f (tt_ctxt ist) = 0 | otherwise = max (100 - d) 1 - conDepth d (PApp _ f as) + conDepth d (PApp _ f as) = conDepth d f + sum (map (conDepth (d+1)) (map getTm as)) conDepth d (PPatvar _ _) = 0 conDepth d (PAlternative _ as) = maximum (map (conDepth d) as) @@ -598,7 +605,7 @@ Nothing -> return () Just b -> case unApply (binderTy b) of - (P _ c _, args) -> + (P _ c _, args) -> case lookupCtxt c (idris_classes ist) of [] -> return () _ -> -- type class, set as injective @@ -611,7 +618,7 @@ probs <- get_probs traceWhen ulog (qshow probs) $ return () _ -> return () - + setinjArg (P _ n _) = setinj n setinjArg _ = return () @@ -630,7 +637,7 @@ solve elab' ina Placeholder = do (h : hs) <- get_holes movelast h - elab' ina (PMetavar n) = + elab' ina (PMetavar n) = do ptm <- get_term -- When building the metavar application, leave out the unique -- names which have been used elsewhere in the term, since we @@ -692,24 +699,13 @@ letbind scvn (Var tyn) (Var valn) focus valn elabE (True, a, inty, qq) scr + -- Solve any remaining implicits - we need to solve as many + -- as possible before making the 'case' type + unifyProblems + matchProblems True args <- get_env envU <- mapM (getKind args) args let namesUsedInRHS = nub $ scvn : concatMap (\(_,rhs) -> allNamesIn rhs) opts --- ++ allNamesIn scr - - -- in the definition we build for the case, only pass through - -- names which are directly used, type class constraints, and - -- variables any of these depend on - -- FIXME: This probably doesn't help us, but leaving it in - -- temporarily (but commented out). If this comment is still - -- here in master, please delete the code! --- let directUse = filter (\n -> usedIn namesUsedInRHS n --- || tcName (binderTy (snd n))) args --- let args' = args -- chaseDeps args (map fst directUse) directUse --- let argsDropped = map fst $ --- filter (\(n, _) -> case lookup n args' of --- Nothing -> True --- _ -> False) args -- Drop the unique arguments used in the scrutinee (since it's -- not valid to use them again anyway) @@ -720,7 +716,7 @@ let cname' = mkN cname -- elab' ina (PMetavar cname') attack; defer argsDropped cname'; solve - + -- if the scrutinee is one of the 'args' in env, we should -- inspect it directly, rather than adding it as a new argument let newdef = PClauses fc [] cname' @@ -744,10 +740,10 @@ Just u -> u _ -> False - getKind env (n, _) + getKind env (n, _) = case lookup n env of Nothing -> return (n, False) -- can't happen, actually... - Just b -> + Just b -> do ty <- get_type (forget (binderTy b)) case ty of UType UniqueType -> return (n, True) @@ -760,8 +756,8 @@ _ -> False tcName _ = False - usedIn ns (n, b) - = n `elem` ns + usedIn ns (n, b) + = n `elem` ns || any (\x -> x `elem` ns) (allTTNames (binderTy b)) -- FIXME: This probably doesn't help us here, but leaving @@ -787,7 +783,7 @@ = do -- First extract the unquoted subterms, replacing them with fresh -- names in the quasiquoted term. Claim their reflections to be -- of type TT. - (t, unq) <- extractUnquotes t + (t, unq) <- extractUnquotes 0 t let unquoteNames = map fst unq mapM_ (flip claim (Var tt)) unquoteNames @@ -868,7 +864,7 @@ isScr (PRef _ n) (n', b) = (n', (n == n', b)) isScr _ (n', b) = (n', (False, b)) - caseBlock :: FC -> Name -> + caseBlock :: FC -> Name -> [(Name, (Bool, Binder Term))] -> [(PTerm, PTerm)] -> [PClause] caseBlock fc n env opts = let args' = findScr env @@ -878,12 +874,12 @@ where -- Find the variable we want as the scrutinee and mark it as -- 'True'. If the scrutinee is in the environment, match on that -- otherwise match on the new argument we're adding. - findScr ((n, (True, t)) : xs) + findScr ((n, (True, t)) : xs) = (n, (True, t)) : scrName n xs - findScr [(n, (_, t))] = [(n, (True, t))] + findScr [(n, (_, t))] = [(n, (True, t))] findScr (x : xs) = x : findScr xs -- [] can't happen since scrutinee is in the environment! - + -- To make sure top level pattern name remains in scope, put -- it at the end of the environment scrName n [] = [] @@ -927,7 +923,7 @@ _ -> return t where mkDelay env (PAlternative b xs) = PAlternative b (map (mkDelay env) xs) - mkDelay env t + mkDelay env t = let fc = fileFC "Delay" in addImplBound ist (map fst env) (PApp fc (PRef fc (sUN "Delay")) [pexp t]) @@ -994,10 +990,10 @@ failed' <- -- trace (show (n, t, hs, tm)) $ -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $ case holeName `elem` hs of - True -> do focus holeName; + True -> do focus holeName; g <- goal ulog <- getUnifyLog - traceWhen ulog ("Elaborating argument " ++ show (argName, holeName, g)) $ + traceWhen ulog ("Elaborating argument " ++ show (argName, holeName, g)) $ elab ina t; return failed False -> return failed done_elaborating_arg f argName @@ -1040,7 +1036,8 @@ -- Rule out alternatives that don't return the same type as the head of the goal -- (If there are none left as a result, do nothing) -pruneByType :: [Name] -> Term -> Context -> [PTerm] -> [PTerm] +pruneByType :: [Name] -> Term -> -- head of the goal + Context -> [PTerm] -> [PTerm] -- if an alternative has a locally bound name at the head, take it pruneByType env t c as | Just a <- locallyBound as = [a] @@ -1053,10 +1050,10 @@ getName (PRef _ n) = Just n getName (PApp _ f _) = getName f getName _ = Nothing - -pruneByType env (P _ n _) c as + +pruneByType env (P _ n _) ctxt as -- if the goal type is polymorphic, keep e - | [] <- lookupTy n c = as + | [] <- lookupTy n ctxt = as | otherwise = let asV = filter (headIs True n) as as' = filter (headIs False n) as in @@ -1072,13 +1069,16 @@ headIs _ _ _ = True -- keep if it's not an application typeHead var f f' - = case lookupTy f' c of - [ty] -> let ty' = normalise c [] ty in - case unApply (getRetTy ty') of - (P _ ftyn _, _) -> ftyn == f - (V _, _) -> var -- keep, variable - _ -> False - _ -> False + = -- trace ("Trying " ++ show f' ++ " for " ++ show n) $ + case lookupTy f' ctxt of + [ty] -> case unApply (getRetTy ty) of + (P _ ctyn _, _) | isConName ctyn ctxt -> ctyn == f + _ -> let ty' = normalise ctxt [] ty in + case unApply (getRetTy ty') of + (P _ ftyn _, _) -> ftyn == f + (V _, _) -> var -- keep, variable + _ -> False + _ -> False pruneByType _ t _ as = as @@ -1094,11 +1094,11 @@ = trivial (elab ist toplevel ERHS [] (sMN 0 "tac")) ist proofSearch' ist rec depth prv top n hints = do unifyProblems - proofSearch rec prv depth + proofSearch rec prv depth (elab ist toplevel ERHS [] (sMN 0 "tac")) top n hints ist resolveTC :: Bool -> Int -> Term -> Name -> IState -> ElabD () -resolveTC = resTC' [] +resolveTC = resTC' [] resTC' tcs def 0 topg fn ist = fail $ "Can't resolve type class" resTC' tcs def 1 topg fn ist = try' (trivial' ist) (resolveTC def 0 topg fn ist) True @@ -1108,7 +1108,7 @@ ptm <- get_term ulog <- getUnifyLog hs <- get_holes - traceWhen ulog ("Resolving class " ++ show g) $ + traceWhen ulog ("Resolving class " ++ show g) $ try' (trivial' ist) (do t <- goal let (tc, ttypes) = unApply t @@ -1125,7 +1125,7 @@ -- HACK! Rather than giving a special name, better to have some kind -- of flag in ClassInfo structure - chaser (UN nm) + chaser (UN nm) | ('@':'@':_) <- str nm = True -- old way chaser (SN (ParentN _ _)) = True chaser (NS n _) = chaser n @@ -1169,7 +1169,7 @@ args <- map snd <$> try' (apply (Var n) imps) (match_apply (Var n) imps) True ps' <- get_probs - when (length ps < length ps' || unrecoverable ps') $ + when (length ps < length ps' || unrecoverable ps') $ fail "Can't apply type class" -- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $ mapM_ (\ (_,n) -> do focus n @@ -1177,7 +1177,7 @@ let (tc', ttype) = unApply t' let got = fst (unApply t) let depth' = if tc' `elem` tcs - then depth - 1 else depth + then depth - 1 else depth resTC' (got : tcs) defaultOn depth' topg fn ist) (filter (\ (x, y) -> not x) (zip (map fst imps) args)) -- if there's any arguments left, we've failed to resolve @@ -1228,11 +1228,11 @@ -- if a tactic adds unification problems, return an error runTac :: Bool -> IState -> Name -> PTactic -> ElabD () -runTac autoSolve ist fn tac +runTac autoSolve ist fn tac = do env <- get_env g <- goal let tac' = fmap (addImplBound ist (map fst env)) tac - if autoSolve + if autoSolve then runT tac' else no_errors (runT tac') (Just (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env))) @@ -1394,11 +1394,11 @@ letbind scriptvar scriptTy (Var script) focus script ptm <- get_term - elab ist toplevel ERHS [] (sMN 0 "tac") + elab ist toplevel ERHS [] (sMN 0 "tac") (PApp emptyFC tm [pexp (delabTy' ist [] tgoal True True)]) (script', _) <- get_type_val (Var scriptvar) -- now that we have the script apply - -- it to the reflected goal + -- it to the reflected goal restac <- getNameFrom (sMN 0 "restac") claim restac tacticTy focus restac @@ -1478,7 +1478,7 @@ reifyApp :: IState -> Name -> [Term] -> ElabD PTactic reifyApp ist t [l, r] | t == reflm "Try" = liftM2 Try (reify ist l) (reify ist r) -reifyApp _ t [Constant (I i)] +reifyApp _ t [Constant (I i)] | t == reflm "Search" = return (ProofSearch True True i Nothing []) reifyApp _ t [x] | t == reflm "Refine" = do n <- reifyTTName x @@ -2219,4 +2219,3 @@ ] solveAll = try (do solve; solveAll) (return ()) - diff --git a/src/Idris/Erasure.hs b/src/Idris/Erasure.hs --- a/src/Idris/Erasure.hs +++ b/src/Idris/Erasure.hs @@ -201,7 +201,7 @@ -- these have been discovered as builtins but are not listed -- among Idris.Primitives.primitives - , mn "__MkPair" [2,3] + --, mn "__MkPair" [2,3] , it "prim_fork" [0] , it "unsafePerformPrimIO" [1] @@ -342,14 +342,11 @@ -- sanity check: machine-generated names shouldn't occur at top-level | MN _ _ <- n - , n `notElem` specialMNs = error $ "erasure analysis: variable " ++ show n ++ " unbound in " ++ show (S.toList cd) -- assumed to be a global reference | otherwise = M.singleton cd (M.singleton (n, Result) S.empty) - where - specialMNs = map (sMN 0 . ("__" ++)) $ words "Unit True False II" - + -- dependencies of de bruijn variables are described in `bs' getDepsTerm vs bs cd (V i) = snd (bs !! i) cd @@ -361,8 +358,8 @@ -- let-bound variables can get partially evaluated -- it is sufficient just to plug the Cond in when the bound names are used - | Let ty t <- bdr = var t cd `union` getDepsTerm vs ((n, var t) : bs) cd body - | NLet ty t <- bdr = var t cd `union` getDepsTerm vs ((n, var t) : bs) cd body + | Let ty t <- bdr = var t cd `union` getDepsTerm vs ((n, const M.empty) : bs) cd body + | NLet ty t <- bdr = var t cd `union` getDepsTerm vs ((n, const M.empty) : bs) cd body where var t cd = getDepsTerm vs bs cd t diff --git a/src/Idris/Error.hs b/src/Idris/Error.hs --- a/src/Idris/Error.hs +++ b/src/Idris/Error.hs @@ -99,7 +99,6 @@ warnDisamb ist (PCase _ tm cases) = warnDisamb ist tm >> mapM_ (\(x,y)-> warnDisamb ist x >> warnDisamb ist y) cases warnDisamb ist (PTrue _ _) = return () -warnDisamb ist (PFalse _) = return () warnDisamb ist (PRefl _ tm) = warnDisamb ist tm warnDisamb ist (PResolveTC _) = return () warnDisamb ist (PEq _ a b x y) = warnDisamb ist a >> warnDisamb ist b >> diff --git a/src/Idris/Help.hs b/src/Idris/Help.hs --- a/src/Idris/Help.hs +++ b/src/Idris/Help.hs @@ -4,6 +4,7 @@ | NameArg -- ^ The command takes a name | FileArg -- ^ The command takes a file | ModuleArg -- ^ The command takes a module name + | NumberArg -- ^ The command takes a number | NamespaceArg -- ^ The command takes a namespace name | OptionArg -- ^ The command takes an option | MetaVarArg -- ^ The command takes a metavariable @@ -21,6 +22,7 @@ show NameArg = "" show FileArg = "" show ModuleArg = "" + show NumberArg = "" show NamespaceArg = "" show OptionArg = "