idris 0.9.7 → 0.9.8
raw patch · 98 files changed
+7183/−1783 lines, 98 filesdep +Win32dep +language-javadep +libffisetup-changed
Dependencies added: Win32, language-java, libffi, text, unix
Files
- Setup.hs +91/−14
- config.mk +32/−0
- effects/Effect/Exception.idr +4/−1
- effects/Effect/File.idr +1/−1
- effects/Effect/Memory.idr +168/−0
- effects/Effect/Random.idr +8/−8
- effects/Effect/Select.idr +1/−1
- effects/Effect/State.idr +12/−1
- effects/Effect/StdIO.idr +6/−5
- effects/Effects.idr +29/−24
- effects/Makefile +1/−1
- effects/effects.ipkg +3/−1
- idris.cabal +41/−17
- java/src/main/java/org/idris/rts/Closure.java +17/−0
- java/src/main/java/org/idris/rts/ForeignPrimitives.java +271/−0
- java/src/main/java/org/idris/rts/IdrisObject.java +19/−0
- java/src/main/java/org/idris/rts/TailCallClosure.java +26/−0
- js/Runtime-common.js +2/−0
- lib/Builtins.idr +14/−4
- lib/Data/Bits.idr +45/−43
- lib/Data/BoundedList.idr +93/−0
- lib/Data/SortedMap.idr +235/−0
- lib/Data/SortedSet.idr +25/−0
- lib/Data/Vect/Quantifiers.idr +47/−0
- lib/Decidable/Decidable.idr +19/−0
- lib/Decidable/Equality.idr +1/−1
- lib/Decidable/Order.idr +77/−0
- lib/IO.idr +21/−7
- lib/Language/Reflection.idr +166/−9
- lib/Language/Reflection/Utils.idr +185/−0
- lib/Network/Cgi.idr +1/−1
- lib/Prelude.idr +20/−8
- lib/Prelude/Cast.idr +7/−7
- lib/Prelude/Maybe.idr +1/−1
- lib/Prelude/Strings.idr +4/−1
- lib/Providers.idr +5/−0
- lib/Uninhabited.idr +12/−0
- lib/base.ipkg +11/−3
- rts/Makefile +7/−6
- rts/idris_bitstring.c +28/−0
- rts/idris_bitstring.h +4/−0
- rts/idris_gc.c +22/−24
- rts/idris_gmp.c +28/−0
- rts/idris_gmp.h +2/−0
- rts/idris_heap.c +125/−0
- rts/idris_heap.h +29/−0
- rts/idris_main.c +26/−5
- rts/idris_opts.c +110/−0
- rts/idris_opts.h +19/−0
- rts/idris_rts.c +85/−41
- rts/idris_rts.h +21/−15
- rts/idris_stats.c +68/−0
- rts/idris_stats.h +73/−0
- rts/idris_stdfgn.h +0/−1
- rts/libidris_rts.a binary
- src/Core/CaseTree.hs +24/−12
- src/Core/CoreParser.hs +8/−5
- src/Core/Elaborate.hs +66/−24
- src/Core/Evaluate.hs +47/−39
- src/Core/Execute.hs +567/−0
- src/Core/ProofShell.hs +1/−1
- src/Core/ProofState.hs +43/−20
- src/Core/TT.hs +17/−6
- src/Core/Typecheck.hs +3/−3
- src/Core/Unify.hs +71/−17
- src/IRTS/CodegenC.hs +93/−174
- src/IRTS/CodegenJava.hs +1586/−21
- src/IRTS/CodegenJavaScript.hs +40/−39
- src/IRTS/Compiler.hs +26/−15
- src/IRTS/Defunctionalise.hs +2/−2
- src/IRTS/LParser.hs +28/−28
- src/IRTS/Lang.hs +29/−26
- src/IRTS/Simplified.hs +7/−7
- src/Idris/AbsSyntax.hs +179/−20
- src/Idris/AbsSyntaxTree.hs +146/−30
- src/Idris/Completion.hs +34/−37
- src/Idris/Coverage.hs +76/−167
- src/Idris/DataOpts.hs +10/−10
- src/Idris/Delaborate.hs +65/−34
- src/Idris/Docs.hs +6/−6
- src/Idris/ElabDecls.hs +150/−56
- src/Idris/ElabTerm.hs +467/−61
- src/Idris/Error.hs +1/−1
- src/Idris/Help.hs +50/−0
- src/Idris/IBC.hs +78/−31
- src/Idris/IdeSlave.hs +123/−0
- src/Idris/Parser.hs +115/−48
- src/Idris/Primitives.hs +209/−426
- src/Idris/Prover.hs +10/−3
- src/Idris/Providers.hs +28/−0
- src/Idris/REPL.hs +280/−152
- src/Idris/REPLParser.hs +5/−2
- src/Idris/UnusedArgs.hs +2/−2
- src/Main.hs +5/−0
- src/Pkg/Package.hs +3/−3
- src/Util/DynamicLinker.hs +63/−0
- src/Util/System.hs +38/−4
- tutorial/examples/wheres.idr +14/−0
Setup.hs view
@@ -1,34 +1,53 @@ {-# LANGUAGE CPP #-}+import Control.Monad+import Data.IORef+ import Distribution.Simple import Distribution.Simple.InstallDirs as I import Distribution.Simple.LocalBuildInfo as L import qualified Distribution.Simple.Setup as S import qualified Distribution.Simple.Program as P import Distribution.PackageDescription+import Distribution.Text import System.Exit import System.FilePath ((</>), splitDirectories)+import System.Directory import qualified System.FilePath.Posix as Px import System.Process+import qualified Data.Text as T+import qualified Data.Text.IO as TIO -- After Idris is built, we need to check and install the prelude and other libs make verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "make"+mvn verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "mvn" #ifdef mingw32_HOST_OS -- make on mingw32 exepects unix style separators (<//>) = (Px.</>)-idrisCmd local = Px.joinPath $ splitDirectories $ +idrisCmd local = Px.joinPath $ splitDirectories $ ".." <//> buildDir local <//> "idris" <//> "idris"+rtsDir local = Px.joinPath $ splitDirectories $+ ".." <//> buildDir local <//> "rts" <//> "libidris_rts" #else idrisCmd local = ".." </> buildDir local </> "idris" </> "idris"+rtsDir local = ".." </> buildDir local </> "rts" </> "libidris_rts" #endif cleanStdLib verbosity = do make verbosity [ "-C", "lib", "clean", "IDRIS=idris" ] make verbosity [ "-C", "effects", "clean", "IDRIS=idris" ] -installStdLib pkg local verbosity copy+cleanJavaLib verbosity + = do dirty <- doesDirectoryExist ("java" </> "target")+ when dirty $ mvn verbosity [ "-f", "java/pom.xml", "clean" ]+ pomExists <- doesFileExist ("java" </> "pom.xml")+ when pomExists $ removeFile ("java" </> "pom.xml")+ execPomExists <- doesFileExist ("java" </> "executable_pom.xml")+ when pomExists $ removeFile ("java" </> "executable_pom.xml")++installStdLib pkg local withoutEffects verbosity copy = do let dirs = L.absoluteInstallDirs pkg local copy let idir = datadir dirs let icmd = idrisCmd local@@ -38,11 +57,12 @@ , "TARGET=" ++ idir , "IDRIS=" ++ icmd ]- make verbosity- [ "-C", "effects", "install"- , "TARGET=" ++ idir- , "IDRIS=" ++ icmd- ]+ unless withoutEffects $+ make verbosity+ [ "-C", "effects", "install"+ , "TARGET=" ++ idir+ , "IDRIS=" ++ icmd+ ] let idirRts = idir </> "rts" putStrLn $ "Installing run time system in " ++ idirRts make verbosity@@ -51,6 +71,20 @@ , "IDRIS=" ++ icmd ] +installJavaLib pkg local verbosity copy version = do+ let rtsFile = "idris-" ++ display version ++ ".jar"+ putStrLn $ "Installing java libraries" + mvn verbosity [ "install:install-file"+ , "-Dfile=" ++ ("java" </> "target" </> rtsFile)+ , "-DgroupId=org.idris-lang"+ , "-DartifactId=idris"+ , "-Dversion=" ++ display version+ , "-Dpackaging=jar"+ , "-DgeneratePom=True"+ ]+ let dir = datadir $ L.absoluteInstallDirs pkg local copy+ copyFile ("java" </> "executable_pom.xml") (dir </> "executable_pom.xml")+ -- This is a hack. I don't know how to tell cabal that a data file needs -- installing but shouldn't be in the distribution. And it won't make the -- distribution if it's not there, so instead I just delete@@ -63,14 +97,15 @@ , "IDRIS=" ++ icmd ] -checkStdLib local verbosity+checkStdLib local withoutEffects verbosity = do let icmd = idrisCmd local putStrLn $ "Building libraries..." make verbosity [ "-C", "lib", "check" , "IDRIS=" ++ icmd ]- make verbosity+ unless withoutEffects $+ make verbosity [ "-C", "effects", "check" , "IDRIS=" ++ icmd ]@@ -79,19 +114,61 @@ , "IDRIS=" ++ icmd ] +checkJavaLib verbosity = mvn verbosity [ "-f", "java" </> "pom.xml", "package" ]++javaFlag flags = + case lookup (FlagName "java") (S.configConfigurationsFlags flags) of+ Just True -> True+ Just False -> False+ Nothing -> False++noEffectsFlag flags =+ case lookup (FlagName "noeffects") (S.configConfigurationsFlags flags) of+ Just True -> True+ Just False -> False+ Nothing -> False++preparePoms version+ = do pomTemplate <- TIO.readFile ("java" </> "pom_template.xml")+ TIO.writeFile ("java" </> "pom.xml") (insertVersion pomTemplate)+ execPomTemplate <- TIO.readFile ("java" </> "executable_pom_template.xml")+ TIO.writeFile ("java" </> "executable_pom.xml") (insertVersion execPomTemplate)+ where+ insertVersion template = + T.replace (T.pack "$RTS-VERSION$") (T.pack $ display version) template+ -- Install libraries during both copy and install -- See http://hackage.haskell.org/trac/hackage/ticket/718-main = defaultMainWithHooks $ simpleUserHooks+main = do+ defaultMainWithHooks $ simpleUserHooks { postCopy = \ _ flags pkg lbi -> do- installStdLib pkg lbi (S.fromFlag $ S.copyVerbosity flags)+ let verb = S.fromFlag $ S.copyVerbosity flags+ let withoutEffects = noEffectsFlag $ configFlags lbi+ installStdLib pkg lbi withoutEffects verb (S.fromFlag $ S.copyDest flags) , postInst = \ _ flags pkg lbi -> do- installStdLib pkg lbi (S.fromFlag $ S.installVerbosity flags)+ let verb = (S.fromFlag $ S.installVerbosity flags)+ let withoutEffects = noEffectsFlag $ configFlags lbi+ installStdLib pkg lbi withoutEffects verb NoCopyDest+ when (javaFlag $ configFlags lbi) + (installJavaLib pkg + lbi + verb + NoCopyDest + (pkgVersion . package $ localPkgDescr lbi)+ ) , postConf = \ _ flags _ lbi -> do removeLibIdris lbi (S.fromFlag $ S.configVerbosity flags)+ when (javaFlag $ configFlags lbi) + (preparePoms . pkgVersion . package $ localPkgDescr lbi) , postClean = \ _ flags _ _ -> do- cleanStdLib (S.fromFlag $ S.cleanVerbosity flags)+ let verb = S.fromFlag $ S.cleanVerbosity flags+ cleanStdLib verb+ cleanJavaLib verb , postBuild = \ _ flags _ lbi -> do- checkStdLib lbi (S.fromFlag $ S.buildVerbosity flags)+ let verb = S.fromFlag $ S.buildVerbosity flags+ let withoutEffects = noEffectsFlag $ configFlags lbi+ checkStdLib lbi withoutEffects verb+ when (javaFlag $ configFlags lbi) (checkJavaLib verb) }
config.mk view
@@ -1,3 +1,35 @@ GMP_INCLUDE_DIR := CC :=gcc CABAL :=cabal+#CABALFLAGS :=+## Enable Java RTS:+#CABALFLAGS :=-f Java+## Disable building of Effects+#CABALFLAGS :=-f NoEffects+++MACHINE := $(shell $(CC) -dumpmachine)+ifneq (, $(findstring darwin, $(MACHINE)))+ OS :=darwin+else+ifneq (, $(findstring cygwin, $(MACHINE)))+ OS :=windows+else+ifneq (, $(findstring mingw, $(MACHINE)))+ OS :=windows+else+ OS :=unix+endif+endif+endif++ifeq ($(OS),darwin)+ SHLIB_SUFFIX :=.dylib+else+ifeq ($(OS),windows)+ SHLIB_SUFFIX :=.DLL+else+ SHLIB_SUFFIX :=.so+endif+endif+
effects/Effect/Exception.idr view
@@ -17,7 +17,10 @@ instance Handler (Exception a) (IOExcept a) where handle _ (Raise e) k = ioM (return (Left e)) -EXCEPTION : Type -> EFF +instance Handler (Exception a) (Either a) where+ handle _ (Raise e) k = Left e++EXCEPTION : Type -> EFFECT EXCEPTION t = MkEff () (Exception t) raise : a -> Eff m [EXCEPTION a] b
effects/Effect/File.idr view
@@ -40,7 +40,7 @@ handle (FH h) EOF k = do e <- ioe_lift (feof h) k (FH h) e -FILE_IO : Type -> EFF+FILE_IO : Type -> EFFECT FILE_IO t = MkEff t FileIO open : Handler FileIO e =>
+ effects/Effect/Memory.idr view
@@ -0,0 +1,168 @@+module Effect.Memory++import Effects+import Control.IOExcept++%access public++abstract+data MemoryChunk : Nat -> Nat -> Type where+ CH : Ptr -> MemoryChunk size initialized++abstract+data RawMemory : Effect where+ Allocate : (n : Nat) ->+ RawMemory () (MemoryChunk n 0) ()+ Free : RawMemory (MemoryChunk n i) () ()+ Initialize : Bits8 ->+ (size : Nat) ->+ so (i + size <= n) ->+ RawMemory (MemoryChunk n i) (MemoryChunk n (i + size)) ()+ Peek : (offset : Nat) ->+ (size : Nat) ->+ so (offset + size <= i) ->+ RawMemory (MemoryChunk n i) (MemoryChunk n i) (Vect Bits8 size)+ Poke : (offset : Nat) ->+ (Vect Bits8 size) ->+ so (offset <= i && offset + size <= n) ->+ RawMemory (MemoryChunk n i) (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) ->+ RawMemory (MemoryChunk dst_size dst_init)+ (MemoryChunk dst_size (max dst_init (dst_offset + size))) ()+ GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (MemoryChunk n i)++private+do_malloc : Nat -> IOExcept String Ptr+do_malloc size with (fromInteger (cast size) == size)+ | True = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (cast size)+ fail <- ioe_lift $ nullPtr ptr+ if fail then ioe_fail "Cannot allocate memory"+ else return ptr+ | False = ioe_fail "The target architecture does not support adressing enough memory"++private+do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO ()+do_memset ptr offset c size+ = mkForeign (FFun "idris_memset" [FPtr, FInt, FChar, FInt] FUnit)+ ptr (cast offset) c (cast size)++private+do_free : Ptr -> IO ()+do_free ptr = mkForeign (FFun "free" [FPtr] FUnit) ptr++private+do_memmove : Ptr -> Ptr -> Nat -> Nat -> Nat -> IO ()+do_memmove dest src dest_offset src_offset size+ = mkForeign (FFun "idris_memmove" [FPtr, FPtr, FInt, FInt, FInt] FUnit)+ dest src (cast dest_offset) (cast src_offset) (cast size)++private+do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect Bits8 size)+do_peek _ _ O = return (Prelude.Vect.Nil)+do_peek ptr offset (S n)+ = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FChar) ptr (cast offset)+ bs <- do_peek ptr (S offset) n+ Prelude.Monad.return (Prelude.Vect.(::) b bs)++private+do_poke : Ptr -> Nat -> Vect Bits8 size -> IO ()+do_poke _ _ [] = return ()+do_poke ptr offset (b::bs)+ = do mkForeign (FFun "idris_poke" [FPtr, FInt, FChar] FUnit) ptr (cast offset) b+ do_poke ptr (S offset) bs++instance Handler RawMemory (IOExcept String) where+ handle () (Allocate n) k+ = do ptr <- do_malloc n+ k (CH ptr) ()+ handle {res = MemoryChunk _ offset} (CH ptr) (Initialize c size _) k+ = ioe_lift (do_memset ptr offset c size) $> k (CH ptr) ()+ handle (CH ptr) (Free) k+ = ioe_lift (do_free ptr) $> k () ()+ handle (CH ptr) (Peek offset size _) k+ = do res <- ioe_lift (do_peek ptr offset size)+ k (CH ptr) res+ handle (CH ptr) (Poke offset content _) k+ = do ioe_lift (do_poke ptr offset content)+ k (CH ptr) ()+ handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k+ = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)+ k (CH dest_ptr) ()+ handle chunk (GetRawPtr) k+ = k chunk chunk++RAW_MEMORY : Type -> EFFECT+RAW_MEMORY t = MkEff t RawMemory++allocate : (n : Nat) -> EffM m [RAW_MEMORY ()] [RAW_MEMORY (MemoryChunk n 0)] ()+allocate size = Allocate size++initialize : {i : Nat} ->+ {n : Nat} ->+ Bits8 ->+ (size : Nat) ->+ so (i + size <= n) ->+ EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (i + size))] ()+initialize c size prf = Initialize c size prf++free : EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY ()] ()+free = Free++peek : {i : Nat} ->+ (offset : Nat) ->+ (size : Nat) ->+ so (offset + size <= i) ->+ Eff m [RAW_MEMORY (MemoryChunk n i)] (Vect Bits8 size)+peek offset size prf = Peek offset size prf++poke : {n : Nat} ->+ {i : Nat} ->+ (offset : Nat) ->+ Vect Bits8 size ->+ so (offset <= i && offset + size <= n) ->+ EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (max i (offset + size)))] ()+poke offset content prf = Poke offset content prf++private+getRawPtr : Eff m [RAW_MEMORY (MemoryChunk n i)] (MemoryChunk n i)+getRawPtr = GetRawPtr++private+move' : {dst_size : Nat} ->+ {dst_init : Nat} ->+ {src_init : Nat} ->+ (src_ptr : 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) ->+ EffM m [RAW_MEMORY (MemoryChunk dst_size dst_init)]+ [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))] ()+move' src_ptr dst_offset src_offset size dst_bounds src_bounds+ = Move src_ptr dst_offset src_offset size dst_bounds src_bounds++data MoveDescriptor = Dst | Src++move : {dst_size : Nat} ->+ {dst_init : Nat} ->+ {src_size : Nat} ->+ {src_init : Nat} ->+ (dst_offset : Nat) ->+ (src_offset : Nat) ->+ (size : Nat) ->+ so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->+ so (src_offset + size <= src_init) ->+ EffM m [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)+ , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]+ [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))+ , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] ()+move dst_offset src_offset size dst_bounds src_bounds+ = do src_ptr <- Src :- getRawPtr+ Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds+ return ()
effects/Effect/Random.idr view
@@ -3,19 +3,19 @@ import Effects data Random : Type -> Type -> Type -> Type where- getRandom : Random Int Int Int+ getRandom : Random Integer Integer Integer using (m : Type -> Type) instance Handler Random m where handle seed getRandom k- = let seed' = 1664525 * seed + 1013904223 in+ = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in k seed' seed'- -RND : EFF-RND = MkEff Int Random -rndInt : Int -> Int -> Eff m [RND] Int-rndInt lower upper = do v <- getRandom - return (v `mod` (upper - lower) + lower)+RND : EFFECT+RND = MkEff Integer Random++rndInt : Integer -> Integer -> Eff m [RND] Integer+rndInt lower upper = do v <- getRandom+ return (v `prim__sremBigInt` (upper - lower) + lower)
effects/Effect/Select.idr view
@@ -15,7 +15,7 @@ instance Handler Selection List where handle r (Select xs) k = concatMap (k r) xs -SELECT : EFF+SELECT : EFFECT SELECT = MkEff () Selection select : List a -> Eff m [SELECT] a
effects/Effect/State.idr view
@@ -13,7 +13,7 @@ handle st Get k = k st st handle st (Put n) k = k n () -STATE : Type -> EFF+STATE : Type -> EFFECT STATE t = MkEff t State get : Eff m [STATE x] x@@ -28,4 +28,15 @@ update : (x -> x) -> Eff m [STATE x] () update f = do val <- get put (f val) ++updateM : (x -> y) -> EffM m [STATE x] [STATE y] ()+updateM f = do val <- get+ putM (f val) ++locally : x -> Eff m [STATE x] t -> Eff m [STATE y] t+locally newst prog = do st <- get+ putM newst+ val <- prog+ putM st+ return val
effects/Effect/StdIO.idr view
@@ -19,9 +19,6 @@ data IOStream a = MkStream (List String -> (a, List String)) -injStream : a -> IOStream a-injStream v = MkStream (\x => (v, []))- instance Handler StdIO IOStream where handle () (PutStr s) k = MkStream (\x => case k () () of@@ -38,7 +35,7 @@ --- The Effect and associated functions -STDIO : EFF+STDIO : EFFECT STDIO = MkEff () StdIO putStr : Handler StdIO e => String -> Eff e [STDIO] ()@@ -55,5 +52,9 @@ List String -> (a, List String) mkStrFn {a} env p input = case mkStrFn' of MkStream f => f input- where mkStrFn' : IOStream a+ where injStream : a -> IOStream a+ injStream v = MkStream (\x => (v, []))+ mkStrFn' : IOStream a mkStrFn' = runWith injStream env p++
effects/Effects.idr view
@@ -10,8 +10,8 @@ Effect : Type Effect = Type -> Type -> Type -> Type -data EFF : Type where- MkEff : Type -> Effect -> EFF+data EFFECT : Type where+ MkEff : Type -> Effect -> EFFECT class Handler (e : Effect) (m : Type -> Type) where handle : res -> (eff : e res res' t) -> (res' -> t -> m a) -> m a@@ -28,12 +28,12 @@ subListId {xs = Nil} = SubNil subListId {xs = x :: xs} = Keep subListId -data Env : (m : Type -> Type) -> List EFF -> Type where+data Env : (m : Type -> Type) -> List EFFECT -> Type where Nil : Env m Nil (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs) data EffElem : (Type -> Type -> Type -> Type) -> Type ->- List EFF -> Type where+ List EFFECT -> Type where Here : EffElem x a (MkEff a x :: xs) There : EffElem x a xs -> EffElem x a (y :: xs) @@ -59,22 +59,22 @@ ---- The Effect EDSL itself ---- -- some proof automation-findEffElem : Nat -> Tactic -- Nat is maximum search depth-findEffElem O = Refine "Here" `Seq` Solve -findEffElem (S n) = GoalType "EffElem" +findEffElem : Nat -> List (TTName, Binder TT) -> TT -> Tactic -- Nat is maximum search depth+findEffElem O ctxt goal = Refine "Here" `Seq` Solve +findEffElem (S n) ctxt goal = GoalType "EffElem" (Try (Refine "Here" `Seq` Solve)- (Refine "There" `Seq` (Solve `Seq` findEffElem n)))+ (Refine "There" `Seq` (Solve `Seq` findEffElem n ctxt goal))) -findSubList : Nat -> Tactic-findSubList O = Refine "SubNil" `Seq` Solve-findSubList (S n)+findSubList : Nat -> List (TTName, Binder TT) -> TT -> Tactic+findSubList O ctxt goal = Refine "SubNil" `Seq` Solve+findSubList (S n) ctxt goal = GoalType "SubList" (Try (Refine "subListId" `Seq` Solve) ((Try (Refine "Keep" `Seq` Solve)- (Refine "Drop" `Seq` Solve)) `Seq` findSubList n))+ (Refine "Drop" `Seq` Solve)) `Seq` findSubList n ctxt goal)) -updateResTy : (xs : List EFF) -> EffElem e a xs -> e a b t -> - List EFF+updateResTy : (xs : List EFFECT) -> EffElem e a xs -> e a b t -> + List EFFECT updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs updateResTy (x :: xs) (There p) n = x :: updateResTy xs p n @@ -83,7 +83,7 @@ data LRes : lbl -> Type -> Type where (:=) : (x : lbl) -> res -> LRes x res -(:::) : lbl -> EFF -> EFF +(:::) : lbl -> EFFECT -> EFFECT (:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff private@@ -97,11 +97,10 @@ -- the language of Effects data EffM : (m : Type -> Type) ->- List EFF -> List EFF -> Type -> Type where+ List EFFECT -> List EFFECT -> Type -> Type where value : a -> EffM m xs xs a ebind : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b- effect : {a, b: _} -> {e : Effect} ->- (prf : EffElem e a xs) -> + effect : (prf : EffElem e a xs) -> (eff : e a b t) -> EffM m xs (updateResTy xs prf eff) t lift : (prf : SubList ys xs) ->@@ -114,17 +113,17 @@ EffM m xs xs' a (:-) : (l : ty) -> EffM m [x] [y] t -> EffM m [l ::: x] [l ::: y] t --- Eff : List (EFF m) -> Type -> Type+-- Eff : List (EFFECT m) -> Type -> Type implicit-lift' : {default tactics { reflect findSubList 10; solve; }+lift' : {default tactics { applyTactic findSubList 100; solve; } prf : SubList ys xs} -> EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t lift' {prf} e = lift prf e implicit effect' : {a, b: _} -> {e : Effect} ->- {default tactics { reflect findEffElem 10; solve; } + {default tactics { applyTactic findEffElem 100; solve; } prf : EffElem e a xs} -> (eff : e a b t) -> EffM m xs (updateResTy xs prf eff) t@@ -176,8 +175,12 @@ eff env (catch prog handler) k = catch (eff env prog k) (\e => eff env (handler e) k)+-- FIXME:+-- xs is needed explicitly because otherwise the pattern binding for+-- 'l' appears too late. Solution seems to be to reorder patterns at the+-- end so that everything is in scope when it needs to be. eff {xs = [l ::: x]} env (l :- prog) k- = let env' = unlabel {l} env in+ = let env' = unlabel env in eff env' prog (\envk, p' => k (relabel l envk) p') run : Applicative m => Env m xs -> EffM m xs xs' a -> m a@@ -189,10 +192,13 @@ runPure : Env id xs -> EffM id xs xs' a -> a runPure env prog = eff env prog (\env, r => r) +runPureEnv : Env id xs -> EffM id xs xs' a -> (Env id xs', a)+runPureEnv env prog = eff env prog (\env, r => (env, r))+ runWith : (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a runWith inj env prog = eff env prog (\env, r => inj r) -Eff : (Type -> Type) -> List EFF -> Type -> Type+Eff : (Type -> Type) -> List EFFECT -> Type -> Type Eff m xs t = EffM m xs xs t -- some higher order things@@ -204,4 +210,3 @@ when : Applicative m => Bool -> Eff m xs () -> Eff m xs () when True e = e when False e = pure ()-
effects/Makefile view
@@ -4,7 +4,7 @@ recheck: clean check -install: +install: $(IDRIS) --install effects.ipkg clean: .PHONY
effects/effects.ipkg view
@@ -3,4 +3,6 @@ opts = "-i ../lib" modules = Effects, Effect.Exception, Effect.File, Effect.State,- Effect.Random, Effect.StdIO, Effect.Select+ Effect.Random, Effect.StdIO, Effect.Select,+ Effect.Memory+
idris.cabal view
@@ -1,5 +1,5 @@ Name: idris-Version: 0.9.7+Version: 0.9.8 License: BSD3 License-file: LICENSE Author: Edwin Brady@@ -10,21 +10,21 @@ Category: Compilers/Interpreters, Dependent Types Synopsis: Functional Programming Language with Dependent Types Description: Idris is a general purpose language with full dependent types.- It is compiled, with eager evaluation. + It is compiled, with eager evaluation. Dependent types allow types to be predicated on values, meaning that some aspects of a program's behaviour can be- specified precisely in the type. The language is closely + specified precisely in the type. The language is closely related to Epigram and Agda. There is a tutorial at <http://www.idris-lang.org/documentation>. Features include: . * Full dependent types with dependent pattern matching- . - * where clauses, with rule, simple case expressions, + .+ * where clauses, with rule, simple case expressions, pattern matching let and lambda bindings . * Type classes, monad comprehensions .- * do notation, idiom brackets, syntactic conveniences for lists, + * do notation, idiom brackets, syntactic conveniences for lists, tuples, dependent pairs . * Totality checking@@ -42,19 +42,24 @@ * Hugs style interactive environment Cabal-Version: >= 1.6++ Build-type: Custom + Data-files: rts/libidris_rts.a rts/idris_rts.h rts/idris_gc.h rts/idris_stdfgn.h rts/idris_main.c rts/idris_gmp.h rts/libtest.c js/Runtime-common.js js/Runtime-node.js js/Runtime-browser.js-Extra-source-files: lib/Makefile lib/*.idr lib/Prelude/*.idr +Extra-source-files: lib/Makefile lib/*.idr lib/Prelude/*.idr lib/Network/*.idr lib/Control/*.idr lib/Control/Monad/*.idr lib/Language/*.idr+ lib/Language/Reflection/*.idr lib/System/Concurrency/*.idr lib/Data/*.idr lib/Debug/*.idr+ lib/Data/Vect/*.idr lib/Decidable/*.idr tutorial/examples/*.idr lib/base.ipkg effects/Makefile effects/*.idr effects/Effect/*.idr@@ -62,30 +67,39 @@ config.mk rts/*.c rts/*.h rts/Makefile js/*.js+ java/src/main/java/org/idris/rts/*.java source-repository head type: git- location: git://github.com/edwinb/Idris-dev.git + location: git://github.com/edwinb/Idris-dev.git +Flag Java+ Description: Build the Java RTS+ Default: False +Flag NoEffects+ Description: Do not build the effects package+ Default: False+ Executable idris Main-is: Main.hs hs-source-dirs: src- Other-modules: Core.TT, Core.Evaluate, Core.Typecheck, - Core.ProofShell, Core.ProofState, Core.CoreParser, + Other-modules: Core.TT, Core.Evaluate, Core.Execute, Core.Typecheck,+ Core.ProofShell, Core.ProofState, Core.CoreParser, Core.ShellParser, Core.Unify, Core.Elaborate, Core.CaseTree, Core.Constraints, Idris.AbsSyntax, Idris.AbsSyntaxTree,- Idris.Parser, Idris.REPL,+ Idris.Parser, Idris.Help, Idris.IdeSlave, Idris.REPL, Idris.REPLParser, Idris.ElabDecls, Idris.Error, Idris.Delaborate, Idris.Primitives, Idris.Imports, Idris.Compiler, Idris.Prover, Idris.ElabTerm, Idris.Coverage, Idris.IBC, Idris.Unlit,- Idris.DataOpts, Idris.Transforms, Idris.DSL, + Idris.DataOpts, Idris.Transforms, Idris.DSL, Idris.UnusedArgs, Idris.Docs, Idris.Completion,+ Idris.Providers, - Util.Pretty, Util.System,+ Util.Pretty, Util.System, Util.DynamicLinker, Pkg.Package, Pkg.PParser, IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified,@@ -96,12 +110,22 @@ Paths_idris - Build-depends: base>=4 && <5, parsec>=3, mtl, Cabal, + Build-depends: base>=4 && <5, parsec>=3, mtl, Cabal, haskeline>=0.7, split, directory,- containers, process, transformers, filepath, - directory, binary, bytestring, pretty- + containers, process, transformers, filepath,+ directory, binary, bytestring, text, pretty,+ language-java>=0.2.2, libffi+ Extensions: MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TemplateHaskell ghc-prof-options: -auto-all -caf-all ghc-options: -rtsopts+ if os(linux)+ cpp-options: -DLINUX+ build-depends: unix+ if os(darwin)+ cpp-options: -DMACOSX+ build-depends: unix+ if os(windows)+ cpp-options: -DWINDOWS+ build-depends: Win32
+ java/src/main/java/org/idris/rts/Closure.java view
@@ -0,0 +1,17 @@+package org.idris.rts;++import java.util.concurrent.Callable;++public abstract class Closure implements Callable<Object>, Runnable {+ protected final Object [] context;++ protected Closure(final Object ... context) {+ this.context = context;+ }++ public void run() {+ call();+ }++ public abstract Object call();+}
+ java/src/main/java/org/idris/rts/ForeignPrimitives.java view
@@ -0,0 +1,271 @@+package org.idris.rts;++import java.lang.reflect.InvocationTargetException;+import java.util.Arrays;+import java.util.List;+import java.util.Map;+import java.util.HashMap;+import java.util.Set;+import java.util.HashSet;+import java.io.Closeable;+import java.io.File;+import java.io.IOException;+import java.io.PrintStream;+import java.io.InputStream;+import java.nio.ByteBuffer;+import java.nio.file.Files;+import java.nio.file.OpenOption;+import java.nio.file.StandardOpenOption;+import java.nio.channels.Channels;+import java.nio.channels.SeekableByteChannel;+import java.nio.channels.ReadableByteChannel;+import java.util.concurrent.BlockingQueue;+import java.util.concurrent.LinkedBlockingQueue;+import java.util.concurrent.Semaphore;++@SuppressWarnings("unchecked")+public class ForeignPrimitives {++ private static final Map<Thread, List<String>> args = new HashMap<>();+ private static final Semaphore messageMutex = new Semaphore(1);+ private static final Map<Thread, BlockingQueue<Object>> messages = new HashMap<>();+ private static final Set<Object> feofFiles = new HashSet<>();++ public static synchronized void idris_initArgs(Thread t, String[] args) {+ ForeignPrimitives.args.put(t, Arrays.asList(args));+ }++ public static synchronized int idris_numArgs(Object thread) {+ List<String> argsForThread = ForeignPrimitives.args.get((Thread) thread);+ return (argsForThread == null ? 0 : argsForThread.size());+ }++ public static synchronized String idris_getArg(Object thread, int num) {+ List<String> argsForThread = ForeignPrimitives.args.get((Thread) thread);+ return (argsForThread == null ? null : argsForThread.get(num));+ }++ public static String getenv(String x) {+ return System.getenv(x);+ }++ public static void exit(int exitCode) {+ System.exit(exitCode);+ }++ public static void usleep(int microsecs) {+ try {+ Thread.sleep(microsecs / 1000, microsecs % 1000);+ } catch (InterruptedException ex) {+ }+ }++ public static void idris_sendMessage(Object from, Object dest, Object message) throws InterruptedException {+ messageMutex.acquire();+ BlockingQueue<Object> messagesForTarget = messages.get((Thread) dest);+ if (messagesForTarget == null) {+ messagesForTarget = new LinkedBlockingQueue<>();+ messages.put((Thread) dest, messagesForTarget);+ }+ messagesForTarget.put(message);+ messageMutex.release();+ }++ public static int idris_checkMessage(Object dest) throws InterruptedException {+ messageMutex.acquire();+ BlockingQueue<Object> messagesForTarget = messages.get((Thread) dest);+ messageMutex.release();+ return (messagesForTarget == null ? 0 : messagesForTarget.size());+ }++ public static Object idris_recvMessage(Object dest) throws InterruptedException {+ messageMutex.acquire();+ BlockingQueue<Object> messagesForTarget = messages.get((Thread) dest);+ if (messagesForTarget == null) {+ messagesForTarget = new LinkedBlockingQueue();+ messages.put((Thread) dest, messagesForTarget);+ }+ messageMutex.release();+ return messagesForTarget.take();+ }++ public static void putStr(String str) {+ System.out.print(str);+ }++ public static void putchar(char c) {+ System.out.print(c);+ }++ public static int getchar() {+ try {+ return (char) System.in.read();+ } catch (IOException ex) {+ return -1;+ }+ }++ public static SeekableByteChannel fileOpen(String name, String privs) {+ try {+ OpenOption[] options;+ switch (privs) {+ case "r":+ options = new StandardOpenOption[]{StandardOpenOption.READ};+ break;+ case "r+":+ options = new StandardOpenOption[]{StandardOpenOption.READ,+ StandardOpenOption.WRITE};+ break;+ case "w":+ options = new StandardOpenOption[]{StandardOpenOption.WRITE,+ StandardOpenOption.CREATE};+ break;+ case "w+":+ options = new StandardOpenOption[]{StandardOpenOption.READ,+ StandardOpenOption.WRITE,+ StandardOpenOption.CREATE};+ break;+ case "a":+ options = new StandardOpenOption[]{StandardOpenOption.WRITE,+ StandardOpenOption.CREATE,+ StandardOpenOption.APPEND};+ break;+ case "a+":+ options = new StandardOpenOption[]{StandardOpenOption.READ,+ StandardOpenOption.WRITE,+ StandardOpenOption.CREATE,+ StandardOpenOption.APPEND};+ break;+ default:+ options = new StandardOpenOption[]{};+ break;+ }+ return Files.newByteChannel(new File(name).toPath(), options);+ } catch (IOException ex) {+ return null;+ }+ }++ public static synchronized void fileClose(Object file) throws IOException {+ ((Closeable) file).close();+ feofFiles.remove(file);+ }++ public static void fputStr(Object file, String string) throws IOException {+ if (file instanceof PrintStream) {+ ((PrintStream) file).print(string);+ } else if (file instanceof SeekableByteChannel) {+ ((SeekableByteChannel) file).write(ByteBuffer.wrap(string.getBytes()));+ }+ }++ public static synchronized String idris_readStr(Object file) throws IOException {+ ReadableByteChannel channel = file instanceof InputStream+ ? Channels.newChannel((InputStream) file)+ : (ReadableByteChannel) file;+ ByteBuffer buf = ByteBuffer.allocate(1);+ StringBuilder resultBuilder = new StringBuilder("");+ String delimiter = System.getProperty("line.separator");+ int read = 0;+ do {+ buf.rewind();+ read = channel.read(buf);+ if (read > 0) {+ resultBuilder.append(new String(buf.array()));+ if (resultBuilder.lastIndexOf(delimiter) > -1) {+ return resultBuilder.toString();+ }+ }+ if (read < 0) {+ feofFiles.add(file);+ }+ } while (read >= 0);+ return resultBuilder.toString();+ }++ public static int fileEOF(Object file) {+ return (feofFiles.contains(file) ? 1 : 0);+ }++ public static int isNull(Object o) {+ return (o == null ? 1 : 0);+ }++ public static Object malloc(int size) {+ return ByteBuffer.allocate(size);+ }++ public static void idris_memset(Object buf, int offset, Object c, int size) {+ ByteBuffer buffer = (ByteBuffer)buf;+ buffer.rewind();+ buffer.position(offset);+ byte init[] = new byte[size];+ Arrays.fill(init, (Byte)c);+ buffer.put(init, offset, size);+ buffer.rewind();+ }++ public static void free(Object buf) {+ buf = null;+ }++ public static Integer idris_peek(Object buf, int offset) {+ ByteBuffer buffer = (ByteBuffer)buf;+ return Integer.valueOf(buffer.get(offset));+ }++ public static void idris_poke(Object buf, int offset, Object data) {+ ByteBuffer buffer = (ByteBuffer)buf;+ buffer.put(offset, (Byte)data);+ }++ public static void idris_memmove(Object dstBuf, Object srcBuf, int dstOffset, int srcOffset, int size) {+ ByteBuffer dst = (ByteBuffer)dstBuf;+ ByteBuffer src = (ByteBuffer)srcBuf;+ byte [] srcData = new byte[size];+ src.rewind();+ src.position(srcOffset);+ src.get(srcData, 0, size);+ src.rewind();+ dst.rewind();+ dst.position(dstOffset);+ dst.put(srcData, 0, size);+ dst.rewind();+ }++ public final static Object idris_K(final Object result, final Object drop) {+ return result;+ }++ public final static Object idris_flipK(final Object drop, final Object result) {+ return result;+ }++ public final static Object idris_assignStack(final Object[] context, final int start, final Object... vars) {+ int i = start;+ for (Object var : vars) {+ context[i] = var;+ }+ return context;+ }++ public final static Object invokeOn(final Object obj, final String methodName, Object... args) throws NoSuchMethodException, IllegalAccessException, InvocationTargetException {+ Class cls = (obj instanceof Class ? (Class)obj : obj.getClass());+ Class argClasses[] = new Class[args.length];+ int i = 0;+ for (Object arg : args) {+ argClasses[i] = arg.getClass();+ }+ return cls.getMethod(methodName, argClasses).invoke(obj, args);+ }+ + public final static Object newObject(final Object cls, Object... args) throws NoSuchMethodException, IllegalAccessException, InvocationTargetException, InstantiationException {+ Class clazz = (cls instanceof Class ? (Class)cls : cls.getClass());+ Class argClasses[] = new Class[args.length];+ int i = 0;+ for (Object arg : args) {+ argClasses[i] = arg.getClass();+ }+ return clazz.getConstructor(argClasses).newInstance(args);+ }+}
+ java/src/main/java/org/idris/rts/IdrisObject.java view
@@ -0,0 +1,19 @@+package org.idris.rts;++public class IdrisObject {+ private final int constructorId;+ private final Object data[];+ + public IdrisObject(final int constructorId, final Object ... data) {+ this.constructorId = constructorId;+ this.data = data;+ }+ + public int getConstructorId() {+ return constructorId;+ }++ public Object[] getData() {+ return data;+ }+}
+ java/src/main/java/org/idris/rts/TailCallClosure.java view
@@ -0,0 +1,26 @@+package org.idris.rts;++public class TailCallClosure extends Closure {+ private final Closure function;++ public TailCallClosure(Closure function) {+ super();+ this.function = function;+ }++ public final Object call() {+ Closure function = this.function;+ Object result = null;+ while (function != null) {+ result = function.call();+ function = null;+ if (result instanceof TailCallClosure) {+ function = ((TailCallClosure)result).function;+ } else {+ return result;+ }+ }+ return result;+ }+}+
js/Runtime-common.js view
@@ -10,7 +10,9 @@ __IDRRT__.String = new __IDRRT__.Type('String'); __IDRRT__.Integer = new __IDRRT__.Type('Integer'); __IDRRT__.Float = new __IDRRT__.Type('Float');+__IDRRT__.Ptr = new __IDRRT__.Type('Pointer') __IDRRT__.Forgot = new __IDRRT__.Type('Forgot');+ /** @constructor */ __IDRRT__.Tailcall = function(f) { this.f = f };
lib/Builtins.idr view
@@ -25,6 +25,13 @@ lazy : a -> a lazy x = x -- compiled specially +-- Give the termination checker a hint.+-- assert_smaller x v means that 'v' should be assumed smaller than the+-- variable x in this call.++assert_smaller : a -> b -> b+assert_smaller var smallerval = smallerval -- compiled specially+ par : |(thunk:a) -> a par x = x -- compiled specially @@ -44,6 +51,9 @@ namespace Builtins { +Not : Type -> Type+Not a = a -> _|_+ id : a -> a id x = x @@ -248,7 +258,7 @@ (*) = prim__mulBigInt abs x = if x<0 then -x else x- fromInteger = prim__intToBigInt+ fromInteger = prim__sextInt_BigInt instance Num Float where @@ -257,15 +267,15 @@ (*) = prim__mulFloat abs x = if x<0 then -x else x- fromInteger = prim__intToFloat + fromInteger = prim__toFloatInt partial div : Int -> Int -> Int-div = prim__divInt+div = prim__sdivInt partial mod : Int -> Int -> Int-mod = prim__modInt+mod = prim__sremInt (/) : Float -> Float -> Float
lib/Data/Bits.idr view
@@ -31,17 +31,17 @@ natToBits' : machineTy n -> Nat -> machineTy n natToBits' a O = a natToBits' {n=n} a x with n- natToBits' a (S x') | O = natToBits' (prim__addB8 a (prim__intToB8 1)) x'- natToBits' a (S x') | S O = natToBits' (prim__addB16 a (prim__intToB16 1)) x'- natToBits' a (S x') | S (S O) = natToBits' (prim__addB32 a (prim__intToB32 1)) x'- natToBits' a (S x') | S (S (S _)) = natToBits' (prim__addB64 a (prim__intToB64 1)) x'+ natToBits' a (S x') | O = natToBits' (prim__addB8 a (prim__truncInt_B8 1)) x'+ natToBits' a (S x') | S O = natToBits' (prim__addB16 a (prim__truncInt_B16 1)) x'+ natToBits' a (S x') | S (S O) = natToBits' (prim__addB32 a (prim__truncInt_B32 1)) x'+ natToBits' a (S x') | S (S (S _)) = natToBits' (prim__addB64 a (prim__truncInt_B64 1)) x' natToBits : Nat -> machineTy n natToBits {n=n} x with n- | O = natToBits' (prim__intToB8 0) x- | S O = natToBits' (prim__intToB16 0) x- | S (S O) = natToBits' (prim__intToB32 0) x- | S (S (S _)) = natToBits' (prim__intToB64 0) x+ | O = natToBits' (prim__truncInt_B8 0) x+ | S O = natToBits' (prim__truncInt_B16 0) x+ | S (S O) = natToBits' (prim__truncInt_B32 0) x+ | S (S (S _)) = natToBits' (prim__truncInt_B64 0) x getPad : Nat -> machineTy n getPad n = natToBits ((bitsUsed (nextBytes n)) - n)@@ -111,7 +111,8 @@ public shiftRightLogical : Bits n -> Bits n -> Bits n-shiftRightLogical (MkBits x) (MkBits y) = MkBits (shiftRightLogical' x y)+shiftRightLogical {n} (MkBits x) (MkBits y) + = MkBits {n} (shiftRightLogical' {n=nextBytes n} x y) shiftRightArithmetic' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) shiftRightArithmetic' {n=n} x c with (nextBytes n)@@ -133,7 +134,7 @@ public and : Bits n -> Bits n -> Bits n-and (MkBits x) (MkBits y) = MkBits (and' x y)+and {n} (MkBits x) (MkBits y) = MkBits (and' {n=nextBytes n} x y) or' : machineTy n -> machineTy n -> machineTy n or' {n=n} x y with n@@ -144,7 +145,7 @@ public or : Bits n -> Bits n -> Bits n-or (MkBits x) (MkBits y) = MkBits (or' x y)+or {n} (MkBits x) (MkBits y) = MkBits (or' {n=nextBytes n} x y) xor' : machineTy n -> machineTy n -> machineTy n xor' {n=n} x y with n@@ -308,14 +309,14 @@ zext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) | (O, O) = believe_me x- | (O, S O) = believe_me (prim__zextB8_16 (believe_me x))- | (O, S (S O)) = believe_me (prim__zextB8_32 (believe_me x))- | (O, S (S (S _))) = believe_me (prim__zextB8_64 (believe_me x))+ | (O, S O) = believe_me (prim__zextB8_B16 (believe_me x))+ | (O, S (S O)) = believe_me (prim__zextB8_B32 (believe_me x))+ | (O, S (S (S _))) = believe_me (prim__zextB8_B64 (believe_me x)) | (S O, S O) = believe_me x- | (S O, S (S O)) = believe_me (prim__zextB16_32 (believe_me x))- | (S O, S (S (S _))) = believe_me (prim__zextB16_64 (believe_me x))+ | (S O, S (S O)) = believe_me (prim__zextB16_B32 (believe_me x))+ | (S O, S (S (S _))) = believe_me (prim__zextB16_B64 (believe_me x)) | (S (S O), S (S O)) = believe_me x- | (S (S O), S (S (S _))) = believe_me (prim__zextB32_64 (believe_me x))+ | (S (S O), S (S (S _))) = believe_me (prim__zextB32_B64 (believe_me x)) | (S (S (S _)), S (S (S _))) = believe_me x public@@ -326,13 +327,13 @@ intToBits' : Int -> machineTy (nextBytes n) intToBits' {n=n} x with (nextBytes n) | O = let pad = getPad {n=0} n in- prim__lshrB8 (prim__shlB8 (prim__intToB8 x) pad) pad+ prim__lshrB8 (prim__shlB8 (prim__truncInt_B8 x) pad) pad | S O = let pad = getPad {n=1} n in- prim__lshrB16 (prim__shlB16 (prim__intToB16 x) pad) pad+ prim__lshrB16 (prim__shlB16 (prim__truncInt_B16 x) pad) pad | S (S O) = let pad = getPad {n=2} n in- prim__lshrB32 (prim__shlB32 (prim__intToB32 x) pad) pad+ prim__lshrB32 (prim__shlB32 (prim__truncInt_B32 x) pad) pad | S (S (S _)) = let pad = getPad {n=3} n in- prim__lshrB64 (prim__shlB64 (prim__intToB64 x) pad) pad+ prim__lshrB64 (prim__shlB64 (prim__truncInt_B64 x) pad) pad public intToBits : Int -> Bits n@@ -343,10 +344,10 @@ bitsToInt' : machineTy n -> Int bitsToInt' {n=n} x with n- | O = prim__B32ToInt (prim__zextB8_32 x)- | S O = prim__B32ToInt (prim__zextB16_32 x)- | S (S O) = prim__B32ToInt x- | S (S (S _)) = prim__B32ToInt (prim__truncB64_32 x)+ | O = prim__zextB8_Int x+ | S O = prim__zextB16_Int x+ | S (S O) = prim__zextB32_Int x+ | S (S (S _)) = prim__truncB64_Int x public bitsToInt : Bits n -> Int@@ -365,27 +366,27 @@ | (O, O) = let pad = getPad {n=0} n in believe_me (prim__ashrB8 (prim__shlB8 (believe_me x) pad) pad) | (O, S O) = let pad = getPad {n=0} n in- believe_me (prim__ashrB16 (prim__sextB8_16 (prim__shlB8 (believe_me x) pad))- (prim__zextB8_16 pad))+ believe_me (prim__ashrB16 (prim__sextB8_B16 (prim__shlB8 (believe_me x) pad))+ (prim__zextB8_B16 pad)) | (O, S (S O)) = let pad = getPad {n=0} n in- believe_me (prim__ashrB32 (prim__sextB8_32 (prim__shlB8 (believe_me x) pad))- (prim__zextB8_32 pad))+ believe_me (prim__ashrB32 (prim__sextB8_B32 (prim__shlB8 (believe_me x) pad))+ (prim__zextB8_B32 pad)) | (O, S (S (S _))) = let pad = getPad {n=0} n in- believe_me (prim__ashrB64 (prim__sextB8_64 (prim__shlB8 (believe_me x) pad))- (prim__zextB8_64 pad))+ believe_me (prim__ashrB64 (prim__sextB8_B64 (prim__shlB8 (believe_me x) pad))+ (prim__zextB8_B64 pad)) | (S O, S O) = let pad = getPad {n=1} n in believe_me (prim__ashrB16 (prim__shlB16 (believe_me x) pad) pad) | (S O, S (S O)) = let pad = getPad {n=1} n in- believe_me (prim__ashrB32 (prim__sextB16_32 (prim__shlB16 (believe_me x) pad))- (prim__zextB16_32 pad))+ believe_me (prim__ashrB32 (prim__sextB16_B32 (prim__shlB16 (believe_me x) pad))+ (prim__zextB16_B32 pad)) | (S O, S (S (S _))) = let pad = getPad {n=1} n in- believe_me (prim__ashrB64 (prim__sextB16_64 (prim__shlB16 (believe_me x) pad))- (prim__zextB16_64 pad))+ believe_me (prim__ashrB64 (prim__sextB16_B64 (prim__shlB16 (believe_me x) pad))+ (prim__zextB16_B64 pad)) | (S (S O), S (S O)) = let pad = getPad {n=2} n in believe_me (prim__ashrB32 (prim__shlB32 (believe_me x) pad) pad) | (S (S O), S (S (S _))) = let pad = getPad {n=2} n in- believe_me (prim__ashrB64 (prim__sextB32_64 (prim__shlB32 (believe_me x) pad))- (prim__zextB32_64 pad))+ believe_me (prim__ashrB64 (prim__sextB32_B64 (prim__shlB32 (believe_me x) pad))+ (prim__zextB32_B64 pad)) | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad) @@ -397,14 +398,14 @@ trunc' : machineTy (nextBytes (n+m)) -> machineTy (nextBytes n) trunc' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) | (O, O) = believe_me x- | (O, S O) = believe_me (prim__truncB16_8 (believe_me x))- | (O, S (S O)) = believe_me (prim__truncB32_8 (believe_me x))- | (O, S (S (S _))) = believe_me (prim__truncB64_8 (believe_me x))+ | (O, S O) = believe_me (prim__truncB16_B8 (believe_me x))+ | (O, S (S O)) = believe_me (prim__truncB32_B8 (believe_me x))+ | (O, S (S (S _))) = believe_me (prim__truncB64_B8 (believe_me x)) | (S O, S O) = believe_me x- | (S O, S (S O)) = believe_me (prim__truncB32_16 (believe_me x))- | (S O, S (S (S _))) = believe_me (prim__truncB64_16 (believe_me x))+ | (S O, S (S O)) = believe_me (prim__truncB32_B16 (believe_me x))+ | (S O, S (S (S _))) = believe_me (prim__truncB64_B16 (believe_me x)) | (S (S O), S (S O)) = believe_me x- | (S (S O), S (S (S _))) = believe_me (prim__truncB64_32 (believe_me x))+ | (S (S O), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x)) | (S (S (S _)), S (S (S _))) = believe_me x public@@ -437,3 +438,4 @@ instance Show (Bits n) where show = bitsToStr+
+ lib/Data/BoundedList.idr view
@@ -0,0 +1,93 @@+module Data.BoundedList++%access public+%default total++data BoundedList : Type -> Nat -> Type where+ Nil : BoundedList a n+ (::) : a -> BoundedList a n -> BoundedList a (S n)++length : BoundedList a n -> Fin (S n)+length [] = fO+length (x :: xs) = fS (length xs)++--------------------------------------------------------------------------------+-- Indexing into bounded lists+--------------------------------------------------------------------------------++index : Fin (S n) -> BoundedList a n -> Maybe a+index _ [] = Nothing+index fO (x :: _) = Just x+index (fS f) (_ :: xs) = index f xs++--------------------------------------------------------------------------------+-- Adjusting bounds+--------------------------------------------------------------------------------++weaken : BoundedList a n -> BoundedList a (n + m)+weaken [] = []+weaken (x :: xs) = x :: weaken xs++--------------------------------------------------------------------------------+-- Conversions to and from list+--------------------------------------------------------------------------------++take : (n : Nat) -> List a -> BoundedList a n+take _ [] = []+take O _ = []+take (S n') (x :: xs) = x :: take n' xs++toList : BoundedList a n -> List a+toList [] = []+toList (x :: xs) = x :: toList xs++fromList : (xs : List a) -> BoundedList a (length xs)+fromList [] = []+fromList (x :: xs) = x :: fromList xs++--------------------------------------------------------------------------------+-- Building (bigger) bounded lists+--------------------------------------------------------------------------------++replicate : (n : Nat) -> a -> BoundedList a n+replicate O _ = []+replicate (S n) x = x :: replicate n x++--------------------------------------------------------------------------------+-- Folds+--------------------------------------------------------------------------------++foldl : (a -> b -> a) -> a -> BoundedList b n -> a+foldl f e [] = e+foldl f e (x::xs) = foldl f (f e x) xs++foldr : (a -> b -> b) -> b -> BoundedList a n -> b+foldr f e [] = e+foldr f e (x::xs) = f x (foldr f e xs)++--------------------------------------------------------------------------------+-- Maps+--------------------------------------------------------------------------------++map : (a -> b) -> BoundedList a n -> BoundedList b n+map f [] = []+map f (x :: xs) = f x :: map f xs++--------------------------------------------------------------------------------+-- Misc+--------------------------------------------------------------------------------++%assert_total -- not sure why this isn't accepted - clearly decreasing on n+pad : (xs : BoundedList a n) -> (padding : a) -> BoundedList a n+pad {n=O} [] _ = []+pad {n=S n'} [] padding = padding :: (pad {n=n'} [] padding)+pad {n=S n'} (x :: xs) padding = x :: pad {n=n'} xs padding+++--------------------------------------------------------------------------------+-- Simple properties+--------------------------------------------------------------------------------++zeroBoundIsEmpty : (xs : BoundedList a 0) -> xs = the (BoundedList a 0) []+zeroBoundIsEmpty [] = refl+zeroBoundIsEmpty (_ :: _) impossible
+ lib/Data/SortedMap.idr view
@@ -0,0 +1,235 @@+module Data.SortedMap++-- TODO: write merge and split++data Tree : Nat -> Type -> Type -> Type where+ Leaf : k -> v -> Tree O k v+ Branch2 : Tree n k v -> k -> Tree n k v -> Tree (S n) k v+ Branch3 : Tree n k v -> k -> Tree n k v -> k -> Tree n k v -> Tree (S n) k v++branch4 :+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v ->+ Tree (S (S n)) k v+branch4 a b c d e f g =+ Branch2 (Branch2 a b c) d (Branch2 e f g)++branch5 :+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v ->+ Tree (S (S n)) k v+branch5 a b c d e f g h i =+ Branch2 (Branch2 a b c) d (Branch3 e f g h i)++branch6 :+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v ->+ Tree (S (S n)) k v+branch6 a b c d e f g h i j k =+ Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)++branch7 :+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v ->+ Tree (S (S n)) k v+branch7 a b c d e f g h i j k l m =+ Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)++merge1 : Tree n k v -> k -> Tree (S n) k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v+merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i+merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k+merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k+merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m++merge2 : Tree (S n) k v -> k -> Tree n k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v+merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i+merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k+merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k+merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m++merge3 : Tree (S n) k v -> k -> Tree (S n) k v -> k -> Tree n k v -> Tree (S (S n)) k v+merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i+merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k+merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k+merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m++treeLookup : Ord k => k -> Tree n k v -> Maybe v+treeLookup k (Leaf k' v) =+ if k == k' then+ Just v+ else+ Nothing+treeLookup k (Branch2 t1 k' t2) =+ if k <= k' then+ treeLookup k t1+ else+ treeLookup k t2+treeLookup k (Branch3 t1 k1 t2 k2 t3) =+ if k <= k1 then+ treeLookup k t1+ else if k <= k2 then+ treeLookup k t2+ else+ treeLookup k t3++treeInsert' : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree n k v, k, Tree n k v)+treeInsert' k v (Leaf k' v') =+ case compare k k' of+ LT => Right (Leaf k v, k, Leaf k' v')+ EQ => Left (Leaf k v)+ GT => Right (Leaf k' v', k', Leaf k v)+treeInsert' k v (Branch2 t1 k' t2) =+ if k <= k' then+ case treeInsert' k v t1 of+ Left t1' => Left (Branch2 t1' k' t2)+ Right (a, b, c) => Left (Branch3 a b c k' t2)+ else+ case treeInsert' k v t2 of+ Left t2' => Left (Branch2 t1 k' t2')+ Right (a, b, c) => Left (Branch3 t1 k' a b c)+treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =+ if k <= k1 then+ case treeInsert' k v t1 of+ Left t1' => Left (Branch3 t1' k1 t2 k2 t3)+ Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3)+ else+ if k <= k2 then+ case treeInsert' k v t2 of+ Left t2' => Left (Branch3 t1 k1 t2' k2 t3)+ Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3)+ else+ case treeInsert' k v t3 of+ Left t3' => Left (Branch3 t1 k1 t2 k2 t3')+ Right (a, b, c) => Right (Branch2 t1 k2 t2, k2, Branch2 a b c)++treeInsert : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree (S n) k v)+treeInsert k v t =+ case treeInsert' k v t of+ Left t' => Left t'+ Right (a, b, c) => Right (Branch2 a b c)++delType : Nat -> Type -> Type -> Type+delType O k v = ()+delType (S n) k v = Tree n k v++treeDelete : Ord k => k -> Tree n k v -> Either (Tree n k v) (delType n k v)+treeDelete k (Leaf k' v) =+ if k == k' then+ Right ()+ else+ Left (Leaf k' v)+treeDelete {n=S O} k (Branch2 t1 k' t2) =+ if k <= k' then+ case treeDelete k t1 of+ Left t1' => Left (Branch2 t1' k' t2)+ Right () => Right t2+ else+ case treeDelete k t2 of+ Left t2' => Left (Branch2 t1 k' t2')+ Right () => Right t1+treeDelete {n=S O} k (Branch3 t1 k1 t2 k2 t3) =+ if k <= k1 then+ case treeDelete k t1 of+ Left t1' => Left (Branch3 t1' k1 t2 k2 t3)+ Right () => Left (Branch2 t2 k2 t3)+ else if k <= k2 then+ case treeDelete k t2 of+ Left t2' => Left (Branch3 t1 k1 t2' k2 t3)+ Right () => Left (Branch2 t1 k1 t3)+ else+ case treeDelete k t3 of+ Left t3' => Left (Branch3 t1 k1 t2 k2 t3')+ Right () => Left (Branch2 t1 k1 t2)+treeDelete {n=S (S _)} k (Branch2 t1 k' t2) =+ if k <= k' then+ case treeDelete k t1 of+ Left t1' => Left (Branch2 t1' k' t2)+ Right t1' =>+ case t2 of+ Branch2 a b c => Right (Branch3 t1' k' a b c)+ Branch3 a b c d e => Left (branch4 t1' k' a b c d e)+ else+ case treeDelete k t2 of+ Left t2' => Left (Branch2 t1 k' t2')+ Right t2' =>+ case t1 of+ Branch2 a b c => Right (Branch3 a b c k' t2')+ Branch3 a b c d e => Left (branch4 a b c d e k' t2')+treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) =+ if k <= k1 then+ case treeDelete k t1 of+ Left t1' => Left (Branch3 t1' k1 t2 k2 t3)+ Right t1' => Left (merge1 t1' k1 t2 k2 t3)+ else if k <= k2 then+ case treeDelete k t2 of+ Left t2' => Left (Branch3 t1 k1 t2' k2 t3)+ Right t2' => Left (merge2 t1 k1 t2' k2 t3)+ else+ case treeDelete k t3 of+ Left t3' => Left (Branch3 t1 k1 t2 k2 t3')+ Right t3' => Left (merge3 t1 k1 t2 k2 t3')++-- FIXME: this is very inefficient+treeToList : Ord k => Tree n k v -> List (k, v)+treeToList (Leaf k v) = [(k, v)]+treeToList (Branch2 t1 _ t2) = treeToList t1 ++ treeToList t2+treeToList (Branch3 t1 _ t2 _ t3) = treeToList t1 ++ treeToList t2 ++ treeToList t3++data SortedMap : Type -> Type -> Type where+ Empty : SortedMap k v+ M : (n:Nat) -> Tree n k v -> SortedMap k v++empty : SortedMap k v+empty = Empty++lookup : Ord k => k -> SortedMap k v -> Maybe v+lookup _ Empty = Nothing+lookup k (M _ t) = treeLookup k t++insert : Ord k => k -> v -> SortedMap k v -> SortedMap k v+insert k v Empty = M O (Leaf k v)+insert k v (M _ t) =+ case treeInsert k v t of+ Left t' => (M _ t')+ Right t' => (M _ t')++delete : Ord k => k -> SortedMap k v -> SortedMap k v+delete _ Empty = Empty+delete k (M O t) =+ case treeDelete k t of+ Left t' => (M _ t')+ Right () => Empty+delete k (M (S _) t) =+ case treeDelete k t of+ Left t' => (M _ t')+ Right t' => (M _ t')++fromList : Ord k => List (k, v) -> SortedMap k v+fromList l = foldl (flip (uncurry insert)) empty l++toList : Ord k => SortedMap k v -> List (k, v)+toList Empty = []+toList (M _ t) = treeToList t++instance Functor (Tree n k) where+ fmap f (Leaf k v) = Leaf k (f v)+ fmap f (Branch2 t1 k t2) = Branch2 (fmap f t1) k (fmap f t2)+ fmap f (Branch3 t1 k1 t2 k2 t3) = Branch3 (fmap f t1) k1 (fmap f t2) k2 (fmap f t3)++instance Functor (SortedMap k) where+ fmap _ Empty = Empty+ fmap f (M _ t) = M _ (fmap f t)
+ lib/Data/SortedSet.idr view
@@ -0,0 +1,25 @@+module Data.SortedSet++import Data.SortedMap++-- TODO: add intersection, union, difference++data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ())++empty : SortedSet k+empty = SetWrapper Data.SortedMap.empty++insert : Ord k => k -> SortedSet k -> SortedSet k+insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m)++delete : Ord k => k -> SortedSet k -> SortedSet k+delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m)++contains : Ord k => k -> SortedSet k -> Bool+contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)++fromList : Ord k => List k -> SortedSet k+fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l))++toList : Ord k => SortedSet k -> List k+toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)
+ lib/Data/Vect/Quantifiers.idr view
@@ -0,0 +1,47 @@+module Data.Vect.Quantifiers++data Any : (P : a -> Type) -> Vect a n -> Type where+ Here : {P : a -> Type} -> {xs : Vect a n} -> P x -> Any P (x :: xs)+ There : {P : a -> Type} -> {xs : Vect a n} -> Any P xs -> Any P (x :: xs)++anyNilAbsurd : {P : a -> Type} -> Any P Nil -> _|_+anyNilAbsurd Here impossible+anyNilAbsurd There impossible++anyElim : {xs : Vect a n} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b+anyElim _ f (Here p) = f p+anyElim f _ (There p) = f p++any : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect a n) -> Dec (Any P xs)+any _ Nil = No anyNilAbsurd+any p (x::xs) with (p x)+ | Yes prf = Yes (Here prf)+ | No prf =+ case any p xs of+ Yes prf' => Yes (There prf')+ No prf' => No (anyElim prf' prf)++data All : (P : a -> Type) -> Vect a n -> Type where+ Nil : {P : a -> Type} -> All P Nil+ (::) : {P : a -> Type} -> {xs : Vect a n} -> P x -> All P xs -> All P (x :: xs)++negAnyAll : {P : a -> Type} -> {xs : Vect a n} -> 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 a n} -> Not (P x) -> All P (x :: xs) -> _|_+notAllHere _ Nil impossible+notAllHere np (p :: _) = np p++notAllThere : {P : a -> Type} -> {xs : Vect a n} -> Not (All P xs) -> All P (x :: xs) -> _|_+notAllThere _ Nil impossible+notAllThere np (_ :: ps) = np ps++all : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect a n) -> Dec (All P xs)+all _ Nil = Yes Nil+all d (x::xs) with (d x)+ | No prf = No (notAllHere prf)+ | Yes prf =+ case all d xs of+ Yes prf' => Yes (prf :: prf')+ No prf' => No (notAllThere prf')
+ lib/Decidable/Decidable.idr view
@@ -0,0 +1,19 @@+module Decidable.Decidable++%access public++--------------------------------------------------------------------------------+-- Typeclass for decidable n-ary Relations+--------------------------------------------------------------------------------++using (t : Type)+ class Rel (p : t) where+ total liftRel : (Type -> Type) -> Type++ class (Rel p) => Decidable (p : t) where+ total decide : liftRel Dec++using (P : Type, p : P)+ data Given : Dec P -> Type where+ always : Given (Yes p)+
lib/Decidable/Equality.idr view
@@ -75,7 +75,7 @@ leftNotRight refl impossible instance (DecEq a, DecEq b) => DecEq (Either a b) where- decEq {b=b} (Left x') (Left y') with (decEq x' y')+ decEq (Left x') (Left y') with (decEq x' y') | Yes p = Yes $ cong p | No p = No $ \h : Left x' = Left y' => p $ leftInjective {b = b} h decEq (Right x') (Right y') with (decEq x' y')
+ lib/Decidable/Order.idr view
@@ -0,0 +1,77 @@+module Decidable.Order++import Decidable.Decidable+import Decidable.Equality++--------------------------------------------------------------------------------+-- Utility Lemmas+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- Preorders and Posets+--------------------------------------------------------------------------------++class Preorder t (po : t -> t -> Type) where+ total transitive : (a : t) -> (b : t) -> (c : t) -> po a b -> po b c -> po a c+ total reflexive : (a : t) -> po a a++class (Preorder t po) => Poset t (po : t -> t -> Type) where+ total antisymmetric : (a : t) -> (b : t) -> po a b -> po b a -> a = b++--------------------------------------------------------------------------------+-- Natural numbers+--------------------------------------------------------------------------------++data NatLTE : Nat -> Nat -> Type where+ nEqn : NatLTE n n+ nLTESm : NatLTE n m -> NatLTE n (S m)++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 NatLTEIsReflexive : (n : Nat) -> NatLTE n n+NatLTEIsReflexive _ = nEqn++instance Preorder Nat NatLTE where+ transitive = NatLTEIsTransitive+ reflexive = NatLTEIsReflexive++total NatLTEIsAntisymmetric : (m : Nat) -> (n : Nat) -> po m n -> po n m -> m = n+NatLTEIsAntisymmetric n n nEqn nEqn = refl+NatLTEIsAntisymmetric n m nEqn (nLTESm _) impossible+NatLTEIsAntisymmetric n m (nLTESm _) nEqn impossible++instance Poset Nat NatLTE where+ antisymmetric = NatLTEIsAntisymmetric++total zeroNeverGreater : {n : Nat} -> NatLTE (S n) O -> _|_+zeroNeverGreater {n} (nLTESm _) impossible+zeroNeverGreater {n} nEqn impossible++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+decideNatLTE : (n : Nat) -> (m : Nat) -> Dec (NatLTE n m)+decideNatLTE O O = Yes nEqn+decideNatLTE (S x) O = 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 Rel NatLTE where+ liftRel P = (n : Nat) -> (m : Nat) -> P (NatLTE n m)++instance Decidable NatLTE where+ decide = decideNatLTE++lte : (m : Nat) -> (n : Nat) -> Dec (NatLTE m n)+lte m n = decide {p = NatLTE} m n
lib/IO.idr view
@@ -21,22 +21,36 @@ run__IO : IO () -> IO () run__IO v = io_bind v (\v' => io_return v') -data FTy = FInt | FFloat | FChar | FString | FPtr | FAny Type | FUnit+data IntTy = ITNative | IT8 | IT16 | IT32 | IT64+data FTy = FIntT IntTy | FFloat | FString | FPtr | FAny Type | FUnit +FInt : FTy+FInt = FIntT ITNative++FChar : FTy+FChar = FIntT IT8++FShort : FTy+FShort = FIntT IT16++FLong : FTy+FLong = FIntT IT64+ interpFTy : FTy -> Type-interpFTy FInt = Int+interpFTy (FIntT ITNative) = Int+interpFTy (FIntT IT8) = Bits8+interpFTy (FIntT IT16) = Bits16+interpFTy (FIntT IT32) = Bits32+interpFTy (FIntT IT64) = Bits64 interpFTy FFloat = Float-interpFTy FChar = Char interpFTy FString = String interpFTy FPtr = Ptr interpFTy (FAny t) = t interpFTy FUnit = () ForeignTy : (xs:List FTy) -> (t:FTy) -> Type-ForeignTy xs t = mkForeign' (reverse xs) (IO (interpFTy t)) where - mkForeign' : List FTy -> Type -> Type- mkForeign' Nil ty = ty- mkForeign' (s :: ss) ty = mkForeign' ss (interpFTy s -> ty)+ForeignTy Nil rt = IO (interpFTy rt)+ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt data Foreign : Type -> Type where
lib/Language/Reflection.idr view
@@ -1,19 +1,176 @@ module Language.Reflection -TTName : Type-TTName = String -- needs to capture namespaces too...+%access public -data TT = Var TTName- | Lam TTName TT TT- | Pi TTName TT TT- | Let TTName TT TT TT- | App TTName TT TT+data TTName = UN String+ -- ^ User-provided name+ | NS TTName (List String)+ -- ^ Root, namespaces+ | MN Int String+ -- ^ Machine chosen names+ | NErased+ -- ^ Name of somethng which is never used in scope +implicit+userSuppliedName : String -> TTName+userSuppliedName = UN++data TTUExp = UVar Int+ -- ^ universe variable+ | UVal Int+ -- ^ explicit universe variable++-- | Primitive constants+data Const = I Int | BI Nat | Fl Float | Ch Char | Str String+ | IType | BIType | FlType | ChType | StrType+ | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64+ | B8Type | B16Type | B32Type | B64Type+ | PtrType | VoidType | Forgot++abstract class ReflConst (a : Type) where+ toConst : a -> Const++instance ReflConst Int where+ toConst x = I x++instance ReflConst Nat where+ toConst = BI++instance ReflConst Float where+ toConst = Fl++instance ReflConst Char where+ toConst = Ch++instance ReflConst String where+ toConst = Str++instance ReflConst Bits8 where+ toConst = B8++instance ReflConst Bits16 where+ toConst = B16++instance ReflConst Bits32 where+ toConst = B32++instance ReflConst Bits64 where+ toConst = B64++implicit+reflectConstant: (ReflConst a) => a -> Const+reflectConstant = toConst+++-- | 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++-- | Types annotations for bound variables in different+-- binding contexts+data Binder a = Lam a+ | Pi a+ | Let a a+ | NLet a a+ | Hole a+ | GHole a+ | Guess a a+ | PVar a+ | PVTy a+++instance Functor Binder where+ fmap f (Lam x) = Lam (f x)+ fmap f (Pi x) = Pi (f x)+ fmap f (Let x y) = Let (f x) (f y)+ fmap f (NLet x y) = NLet (f x) (f y)+ fmap f (Hole x) = Hole (f x)+ fmap f (GHole x) = GHole (f x)+ fmap f (Guess x y) = Guess (f x) (f y)+ fmap f (PVar x) = PVar (f x)+ fmap f (PVTy x) = PVTy (f x)++total+traverse : (Applicative f) => (a -> f b) -> Binder a -> f (Binder b)+traverse f (Lam x) = [| Lam (f x) |]+traverse f (Pi x) = [| Pi (f x) |]+traverse f (Let x y) = [| Let (f x) (f y) |]+traverse f (NLet x y) = [| NLet (f x) (f y) |]+traverse f (Hole x) = [| Hole (f x) |]+traverse f (GHole x) = [| GHole (f x) |]+traverse f (Guess x y) = [| Guess (f x) (f y) |]+traverse f (PVar x) = [| PVar (f x) |]+traverse f (PVTy x) = [| PVTy (f x) |]+++-- | Reflection of the well typed core language+data TT = P NameType TTName TT+ -- ^ named binders+ | V Int+ -- ^ variables+ | Bind TTName (Binder TT) TT+ -- ^ type annotated named bindings+ | App TT TT+ -- ^ (named) application of a function to a value+ | TConst Const+ -- ^ constants+ | Proj TT Int+ -- ^ argument projection; runtime only+ | Erased+ -- ^ erased terms+ | Impossible+ -- ^ impossible terms+ | TType TTUExp+ -- ^ types++-- | Raw terms without types+data Raw = Var TTName+ | RBind TTName (Binder Raw) Raw+ | RApp Raw Raw+ | RType+ | RForce Raw+ | RConstant Const+ data Tactic = Try Tactic Tactic- | GoalType TTName Tactic -- only run if the goal has the right type+ -- ^ try the first tactic and resort to the second one on failure+ | GoalType String Tactic+ -- ^ only run if the goal has the right type | Refine TTName+ -- ^ resolve function name, find matching arguments in the+ -- context and compute the proof target | Seq Tactic Tactic+ -- ^ apply both tactics in sequence | Trivial+ -- ^ intelligently construct the proof target from the context | Solve- | Exact TT -- not yet implemented+ -- ^ infer the proof target from the context+ | Intros+ -- ^ introduce all variables into the context+ | Intro TTName+ -- ^ introduce a named variable into the context, use the+ -- first one if the given name is not found+ | ApplyTactic TT+ -- ^ invoke the reflected rep. of another tactic+ | Reflect TT+ -- ^ turn a value into its reflected representation+ | Fill Raw+ -- ^ turn a raw value back into a term + | Exact TT+ -- ^ use the given value to conclude the proof+ | Focus TTName+ -- ^ focus a named hole+ | Rewrite TT+ -- ^ rewrite using the reflected rep. of a equality proof+ | LetTac TTName TT+ -- ^ name a reflected term+ | LetTacTy TTName TT TT+ -- ^ name a reflected term and type it+ | Compute+ -- ^ normalise the context
+ lib/Language/Reflection/Utils.idr view
@@ -0,0 +1,185 @@+module Language.Reflection.Utils++--------------------------------------------------------+-- Tactic construction conveniences+--------------------------------------------------------++seq : List Tactic -> Tactic+seq [] = GoalType "This is an impossible case" Trivial+seq [t] = t+seq (t::ts) = t `Seq` seq ts++try : List Tactic -> Tactic+try [] = GoalType "This is an impossible case" Trivial+try [t] = t+try (t::ts) = t `Try` seq ts+++--------------------------------------------------------+-- For use in tactic scripts+--------------------------------------------------------+mkPair : a -> b -> (a, b)+mkPair a b = (a, b)+++--------------------------------------------------------+-- Tools for constructing proof terms directly+--------------------------------------------------------++getUName : TTName -> Maybe String+getUName (UN n) = Just n+getUName (NS n ns) = getUName n+getUName _ = Nothing++unApply : TT -> (TT, List TT)+unApply t = unA t []+ where unA : TT -> List TT -> (TT, List TT)+ unA (App fn arg) args = unA fn (arg::args)+ unA tm args = (tm, args)++mkApp : TT -> List TT -> TT+mkApp tm [] = tm+mkApp tm (a::as) = mkApp (App tm a) as++binderTy : (Eq t) => Binder t -> t+binderTy (Lam t) = t+binderTy (Pi t) = t+binderTy (Let t1 t2) = t1+binderTy (NLet t1 t2) = t1+binderTy (Hole t) = t+binderTy (GHole t) = t+binderTy (Guess t1 t2) = t1+binderTy (PVar t) = t+binderTy (PVTy t) = t++instance Show TTName where+ show (UN str) = "(UN " ++ str ++ ")"+ show (NS n ns) = "(NS " ++ show n ++ " " ++ show ns ++ ")"+ show (MN i str) = "(MN " ++ show i ++ " " ++ show str ++ ")"+ show NErased = "NErased"++instance Eq TTName where+ (UN str1) == (UN str2) = str1 == str2+ (NS n ns) == (NS n' ns') = n == n' && ns == ns'+ (MN i str) == (MN i' str') = i == i' && str == str'+ NErased == NErased = True+ x == y = False++instance Show TTUExp where+ show (UVar i) = "(UVar " ++ show i ++ ")"+ show (UVal i) = "(UVal " ++ show i ++ ")"++instance Eq TTUExp where+ (UVar i) == (UVar j) = i == j+ (UVal i) == (UVal j) = i == j+ x == y = False++instance Show Const where+ show (I i) = "(I " ++ show i ++ ")"+ show (BI n) = "(BI " ++ show n ++ ")"+ show (Fl f) = "(Fl " ++ show f ++ ")"+ show (Ch c) = "(Ch " ++ show c ++ ")"+ show (Str str) = "(Str " ++ show str ++ ")"+ show IType = "IType"+ show BIType = "BIType"+ show FlType = "FlType"+ show ChType = "ChType"+ show StrType = "StrType"+ show (B8 b) = "(B8 ...)"+ show (B16 b) = "(B16 ...)"+ show (B32 b) = "(B32 ...)"+ show (B64 b) = "(B64 ...)"+ show B8Type = "B8Type"+ show B16Type = "B16Type"+ show B32Type = "B32Type"+ show B64Type = "B64Type"+ show PtrType = "PtrType"+ show VoidType = "VoidType"+ show Forgot = "Forgot"++instance Eq Const where+ (I i) == (I i') = i == i'+ (BI n) == (BI n') = n == n'+ (Fl f) == (Fl f') = f == f'+ (Ch c) == (Ch c') = c == c'+ (Str str) == (Str str') = str == str'+ IType == IType = True+ BIType == BIType = True+ FlType == FlType = True+ ChType == ChType = True+ StrType == StrType = True+ (B8 b) == (B8 b') = False -- FIXME: b == b'+ (B16 b) == (B16 b') = False -- FIXME: b == b'+ (B32 b) == (B32 b') = False -- FIXME: b == b'+ (B64 b) == (B64 b') = False -- FIXME: b == b'+ B8Type == B8Type = True+ B16Type == B16Type = True+ B32Type == B32Type = True+ B64Type == B64Type = True+ PtrType == PtrType = True+ VoidType == VoidType = True+ Forgot == Forgot = True+ x == y = False++instance Show NameType where+ show Bound = "Bound"+ show Ref = "Ref"+ show (DCon t ar) = "(DCon " ++ show t ++ " " ++ show ar ++ ")"+ show (TCon t ar) = "(TCon " ++ show t ++ " " ++ show ar ++ ")"++instance Eq NameType where+ Bound == Bound = True+ Ref == Ref = True+ (DCon t ar) == (DCon t' ar') = t == t' && ar == ar'+ (TCon t ar) == (TCon t' ar') = t == t' && ar == ar'+ x == y = False++instance (Show a) => Show (Binder a) where+ show (Lam t) = "(Lam " ++ show t ++ ")"+ show (Pi t) = "(Pi " ++ show t ++ ")"+ show (Let t1 t2) = "(Let " ++ show t1 ++ " " ++ show t2 ++ ")"+ show (NLet t1 t2) = "(NLet " ++ show t1 ++ " " ++ show t2 ++ ")"+ show (Hole t) = "(Hole " ++ show t ++ ")"+ show (GHole t) = "(GHole " ++ show t ++ ")"+ show (Guess t1 t2) = "(Guess " ++ show t1 ++ " " ++ show t2 ++ ")"+ show (PVar t) = "(PVar " ++ show t ++ ")"+ show (PVTy t) = "(PVTy " ++ show t ++ ")"++instance (Eq a) => Eq (Binder a) where+ (Lam t) == (Lam t') = t == t'+ (Pi t) == (Pi t') = t == t'+ (Let t1 t2) == (Let t1' t2') = t1 == t1' && t2 == t2'+ (NLet t1 t2) == (NLet t1' t2') = t1 == t1' && t2 == t2'+ (Hole t) == (Hole t') = t == t'+ (GHole t) == (GHole t') = t == t'+ (Guess t1 t2) == (Guess t1' t2') = t1 == t1' && t2 == t2'+ (PVar t) == (PVar t') = t == t'+ (PVTy t) == (PVTy t') = t == t'+ x == y = False++instance Show TT where+ show = my_show+ where %assert_total my_show : TT -> String+ my_show (P nt n t) = "(P " ++ show nt ++ " " ++ show n ++ " " ++ show t ++ ")"+ my_show (V i) = "(V " ++ show i ++ ")"+ my_show (Bind n b t) = "(Bind " ++ show n ++ " " ++ show b ++ " " ++ show t ++ ")"+ my_show (App t1 t2) = "(App " ++ show t1 ++ " " ++ show t2 ++ ")"+ my_show (TConst c) = "(TConst " ++ show c ++ ")"+ my_show (Proj tm i) = "(Proj " ++ show tm ++ " " ++ show i ++ ")"+ my_show Erased = "Erased"+ my_show Impossible = "Impossible"+ my_show (TType u) = "(TType " ++ show u ++ ")"++instance Eq TT where+ a == b = equalp a b+ where %assert_total equalp : TT -> TT -> Bool+ equalp (P nt n t) (P nt' n' t') = nt == nt' && n == n' && t == t'+ equalp (V i) (V i') = i == i'+ equalp (Bind n b t) (Bind n' b' t') = n == n' && b == b' && t == t'+ equalp (App t1 t2) (App t1' t2') = t1 == t1' && t2 == t2'+ equalp (TConst c) (TConst c') = c == c'+ equalp (Proj tm i) (Proj tm' i') = tm == tm' && i == i'+ equalp Erased Erased = True+ equalp Impossible Impossible = True+ equalp (TType u) (TType u') = u == u'+ equalp x y = False
lib/Network/Cgi.idr view
@@ -121,7 +121,7 @@ runCGI : CGI a -> IO a runCGI prog = do clen_in <- getEnv "CONTENT_LENGTH"- let clen = prim__strToInt clen_in+ let clen = prim__fromStrInt clen_in content <- getContent clen query <- getEnv "QUERY_STRING" cookie <- getEnv "HTTP_COOKIE"
lib/Prelude.idr view
@@ -29,10 +29,10 @@ show (S k) = "s" ++ show k instance Show Int where - show = prim__intToStr+ show = prim__toStrInt instance Show Integer where - show = prim__bigIntToStr+ show = prim__toStrBigInt instance Show Float where show = prim__floatToStr@@ -148,6 +148,10 @@ %include "math.h" %lib "m" +pow : (Num a) => a -> Nat -> a+pow x O = 1+pow x (S n) = x * (pow x n)+ exp : Float -> Float exp x = prim__floatExp x @@ -178,6 +182,15 @@ atan2 : Float -> Float -> Float atan2 y x = atan (y/x) +sinh : Float -> Float+sinh x = (exp x - exp (-x)) / 2++cosh : Float -> Float+cosh x = (exp x + exp (-x)) / 2++tanh : Float -> Float+tanh x = sinh x / cosh x+ sqrt : Float -> Float sqrt x = prim__floatSqrt x @@ -189,12 +202,12 @@ ---- Ranges -%assert_total+partial abstract count : (Ord a, Num a) => a -> a -> a -> List a count a inc b = if a <= b then a :: count (a + inc) inc b else [] -partial+partial abstract countFrom : (Ord a, Num a) => a -> a -> List a countFrom a inc = a :: lazy (countFrom (a + inc) inc) @@ -242,11 +255,11 @@ partial putChar : Char -> IO ()-putChar c = mkForeign (FFun "putchar" [FChar] FUnit) c+putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c) partial getChar : IO Char-getChar = mkForeign (FFun "getchar" [] FChar)+getChar = fmap cast $ mkForeign (FFun "getchar" [] FInt) ---- some basic file handling @@ -268,7 +281,6 @@ partial openFile : String -> Mode -> IO File openFile f m = fopen f (modeStr m) where - modeStr : Mode -> String modeStr Read = "r" modeStr Write = "w" modeStr ReadWrite = "r+"@@ -315,7 +327,7 @@ partial nullPtr : Ptr -> IO Bool-nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p +nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p return (ok /= 0); partial
lib/Prelude/Cast.idr view
@@ -6,24 +6,24 @@ -- String casts instance Cast String Int where- cast = prim__strToInt+ cast = prim__fromStrInt instance Cast String Float where cast = prim__strToFloat instance Cast String Integer where- cast = prim__strToBigInt+ cast = prim__fromStrBigInt -- Int casts instance Cast Int String where- cast = prim__intToStr+ cast = prim__toStrInt instance Cast Int Float where- cast = prim__intToFloat+ cast = prim__toFloatInt instance Cast Int Integer where- cast = prim__intToBigInt + cast = prim__sextInt_BigInt instance Cast Int Char where cast = prim__intToChar@@ -34,12 +34,12 @@ cast = prim__floatToStr instance Cast Float Int where- cast = prim__floatToInt+ cast = prim__fromFloatInt -- Integer casts instance Cast Integer String where- cast = prim__bigIntToStr+ cast = prim__toStrBigInt -- Char casts
lib/Prelude/Maybe.idr view
@@ -66,7 +66,7 @@ -- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to -- <http://en.wikipedia.org/wiki/Monoid>: "Any semigroup S may be -- turned into a monoid simply by adjoining an element i not in S--- and defining i+i = i and i+s = s = s+i for all s ∈ S."+-- and defining i+i = i and i+s = s = s+i for all s in S." instance (Semigroup a) => Semigroup (Maybe a) where Nothing <+> m = m
lib/Prelude/Strings.idr view
@@ -36,7 +36,7 @@ unpack : String -> List Char unpack s with (strM s) unpack "" | StrNil = []- unpack (strCons x xs) | (StrCons _ xs) = x :: unpack xs+ unpack (strCons x xs) | (StrCons x xs) = x :: unpack xs pack : List Char -> String pack [] = ""@@ -114,4 +114,7 @@ unwords : List String -> String unwords = pack . unwords' . map unpack++length : String -> Nat+length = fromInteger . prim_lenString
+ lib/Providers.idr view
@@ -0,0 +1,5 @@+module Providers++public+data Provider a = Provide a | Error String+
+ lib/Uninhabited.idr view
@@ -0,0 +1,12 @@+module Uninhabited++class Uninhabited t where+ total uninhabited : t -> _|_++instance Uninhabited (Fin O) where+ uninhabited fO impossible+ uninhabited (fS f) impossible++instance Uninhabited (O = S n) where+ uninhabited refl impossible+
lib/base.ipkg view
@@ -13,11 +13,19 @@ System.Concurrency.Raw, System.Concurrency.Process, - Decidable.Equality,+ Decidable.Equality, Decidable.Decidable, Decidable.Order, - Language.Reflection,+ Uninhabited, - Data.Morphisms, Data.Bits, Data.Mod2, Data.Z, Data.Sign,+ Providers,++ Language.Reflection, Language.Reflection.Utils,++ Data.Morphisms, +-- Data.Bits, Data.Mod2, + Data.Z, Data.Sign,+ Data.SortedMap, Data.SortedSet, Data.BoundedList,+ Data.Vect.Quantifiers, Control.Monad.Identity, Control.Monad.State, Control.Category, Control.Arrow,
rts/Makefile view
@@ -1,15 +1,16 @@ include ../config.mk -OBJS = idris_rts.o idris_gc.o idris_gmp.o idris_stdfgn.o idris_bitstring.o-HDRS = idris_rts.h idris_gc.h idris_gmp.h idris_stdfgn.h idris_bitstring.h-CFLAGS = -O2 -Wall +OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_stdfgn.o idris_bitstring.o idris_opts.o idris_stats.o+HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_stdfgn.h idris_bitstring.h idris_opts.h idris_stats.h+CFLAGS = -O2 -Wall -fPIC+ ifneq ($(GMP_INCLUDE_DIR),)- CFLAGS += -isystem $(GMP_INCLUDE_DIR)+ CFLAGS += -isystem $(GMP_INCLUDE_DIR) endif LIBTARGET = libidris_rts.a -check : $(LIBTARGET)+check : $(LIBTARGET) $(DYLIBTARGET) $(LIBTARGET) : $(OBJS) ar r $(LIBTARGET) $(OBJS)@@ -20,7 +21,7 @@ install $(LIBTARGET) $(HDRS) $(TARGET) clean : .PHONY- rm -f $(OBJS) $(LIBTARGET)+ rm -f $(OBJS) $(LIBTARGET) $(DYLIBTARGET) idris_rts.o: idris_rts.h
rts/idris_bitstring.c view
@@ -60,6 +60,34 @@ return MKINT((i_int)a->info.bits32); } +VAL idris_b8const(VM *vm, uint8_t a) {+ VAL cl = allocate(vm, sizeof(Closure), 0);+ SETTY(cl, BITS8);+ cl->info.bits8 = a;+ return cl;+}++VAL idris_b16const(VM *vm, uint16_t a) {+ VAL cl = allocate(vm, sizeof(Closure), 0);+ SETTY(cl, BITS16);+ cl->info.bits16 = a;+ return cl;+}++VAL idris_b32const(VM *vm, uint32_t a) {+ VAL cl = allocate(vm, sizeof(Closure), 0);+ SETTY(cl, BITS32);+ cl->info.bits32 = a;+ return cl;+}++VAL idris_b64const(VM *vm, uint64_t a) {+ VAL cl = allocate(vm, sizeof(Closure), 0);+ SETTY(cl, BITS64);+ cl->info.bits64 = a;+ return cl;+}+ VAL idris_b8Plus(VM *vm, VAL a, VAL b) { VAL cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, BITS8);
rts/idris_bitstring.h view
@@ -11,6 +11,10 @@ VAL idris_b32(VM *vm, VAL a); VAL idris_b64(VM *vm, VAL a); VAL idris_castB32Int(VM *vm, VAL a);+VAL idris_b8const(VM *vm, uint8_t a);+VAL idris_b16const(VM *vm, uint16_t a);+VAL idris_b32const(VM *vm, uint32_t a);+VAL idris_b64const(VM *vm, uint64_t a); VAL idris_b8Plus(VM *vm, VAL a, VAL b); VAL idris_b8Minus(VM *vm, VAL a, VAL b);
rts/idris_gc.c view
@@ -55,9 +55,9 @@ void cheney(VM *vm) { int i; int ar;- char* scan = vm->heap;+ char* scan = vm->heap.heap; - while(scan < vm->heap_next) {+ while(scan < vm->heap.next) { size_t inc = *((size_t*)scan); VAL heap_item = (VAL)(scan+sizeof(size_t)); // If it's a CON, copy its arguments@@ -76,21 +76,22 @@ } scan += inc; }- assert(scan == vm->heap_next);+ assert(scan == vm->heap.next); } void idris_gc(VM* vm) {+ HEAP_CHECK(vm)+ STATS_ENTER_GC(vm->stats, vm->heap.size) // printf("Collecting\n"); - char* newheap = malloc(vm -> heap_size);- char* oldheap = vm -> heap;- if (vm->oldheap != NULL) free(vm->oldheap);-- vm->heap = newheap;- vm->heap_next = newheap;- vm->heap_end = newheap + vm->heap_size;+ char* newheap = malloc(vm->heap.size);+ char* oldheap = vm->heap.heap;+ if (vm->heap.old != NULL) + free(vm->heap.old); - vm->collections++;+ vm->heap.heap = newheap;+ vm->heap.next = newheap;+ vm->heap.end = newheap + vm->heap.size; VAL* root; @@ -100,9 +101,7 @@ for(root = vm->inbox_ptr; root < vm->inbox_write; ++root) { *root = copy(vm, *root); }- for(root = vm->argv; root < vm->argv + vm->argc; ++root) {- *root = copy(vm, *root);- }+ vm->ret = copy(vm, vm->ret); vm->reg1 = copy(vm, vm->reg1); @@ -111,20 +110,19 @@ // After reallocation, if we've still more than half filled the new heap, grow the heap // for next time. - if ((vm->heap_next - vm->heap) > vm->heap_size >> 1) {- vm->heap_size += vm->heap_growth;+ if ((vm->heap.next - vm->heap.heap) > vm->heap.size >> 1) {+ vm->heap.size += vm->heap.growth; } - vm->oldheap = oldheap;+ vm->heap.old = oldheap; - // gcInfo(vm, 0);+ STATS_LEAVE_GC(vm->stats, vm->heap.size, vm->heap.next - vm->heap.heap)+ HEAP_CHECK(vm) } void idris_gcInfo(VM* vm, int doGC) {- printf("\nStack: %p %p\n", vm->valstack, vm->valstack_top); - printf("Total allocations: %d\n", vm->allocations);- printf("GCs: %d\n", vm->collections);- printf("Final heap size %d\n", (int)(vm->heap_size));- printf("Final heap use %d\n", (int)(vm->heap_next - vm->heap));+ printf("Stack: <BOT %p> <TOP %p>\n", vm->valstack, vm->valstack_top); + printf("Final heap size %d\n", (int)(vm->heap.size));+ 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));+ printf("Final heap use after GC %d\n", (int)(vm->heap.next - vm->heap.heap)); }
rts/idris_gmp.c view
@@ -52,6 +52,34 @@ return cl; } +VAL MKBIGUI(VM* vm, unsigned long val) {+ mpz_t* bigint;+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0);+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));++ mpz_init_set_ui(*bigint, val);++ SETTY(cl, BIGINT);+ cl -> info.ptr = (void*)bigint;++ return cl;+}++VAL MKBIGSI(VM* vm, signed long val) {+ mpz_t* bigint;+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0);+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));++ mpz_init_set_si(*bigint, val);++ SETTY(cl, BIGINT);+ cl -> info.ptr = (void*)bigint;++ return cl;+}+ VAL GETBIG(VM * vm, VAL x) { if (ISINT(x)) { mpz_t* bigint;
rts/idris_gmp.h view
@@ -5,6 +5,8 @@ VAL MKBIGC(VM* vm, char* bigint); VAL MKBIGM(VM* vm, void* bigint); VAL MKBIGMc(VM* vm, void* bigint);+VAL MKBIGUI(VM* vm, unsigned long val);+VAL MKBIGSI(VM* vm, signed long val); VAL idris_bigPlus(VM*, VAL x, VAL y); VAL idris_bigMinus(VM*, VAL x, VAL y);
+ rts/idris_heap.c view
@@ -0,0 +1,125 @@+#include "idris_heap.h"+#include "idris_rts.h"++#include <stdlib.h>+#include <stddef.h>+#include <stdio.h>++void alloc_heap(Heap * h, size_t heap_size) +{+ char * mem = malloc(heap_size); + if (mem == NULL) {+ fprintf(stderr, + "RTS ERROR: Unable to allocate heap. Requested %d bytes.\n",+ (int)heap_size);+ exit(EXIT_FAILURE);+ }++ h->heap = mem;+ h->next = h->heap;+ h->end = h->heap + heap_size;++ h->size = heap_size;+ h->growth = heap_size;++ h->old = NULL;+}++void free_heap(Heap * h) {+ free(h->heap);++ if (h->old != NULL) { + free(h->old); + }+}++// TODO: more testing+/******************** Heap testing ********************************************/+void heap_check_underflow(Heap * heap) {+ if (!(heap->heap <= heap->next)) {+ fprintf(stderr, "RTS ERROR: HEAP UNDERFLOW <bot %p> <cur %p>\n", + heap->heap, heap->next);+ exit(EXIT_FAILURE);+ }+}++void heap_check_overflow(Heap * heap) {+ if (!(heap->next <= heap->end)) {+ fprintf(stderr, "RTS ERROR: HEAP OVERFLOW <cur %p> <end %p>\n", + heap->next, heap->end);+ exit(EXIT_FAILURE);+ }+}++int is_valid_ref(VAL v) {+ return (v != NULL) && !(ISINT(v));+}++int ref_in_heap(Heap * heap, VAL v) { + return ((VAL)heap->heap <= v) && (v < (VAL)heap->next);+}++// Checks three important properties:+// 1. Closure.+// Check if all pointers in the _heap_ points only to heap. +// 2. Unidirectionality. (if compact gc)+// All references in the heap should be are unidirectional. In other words,+// more recently allocated closure can point only to earlier allocated one.+// 3. After gc there should be no forward references.+//+void heap_check_pointers(Heap * heap) {+ char* scan = NULL;+ + size_t item_size = 0;+ for(scan = heap->heap; scan < heap->next; scan += item_size) {+ item_size = *((size_t*)scan);+ VAL heap_item = (VAL)(scan + sizeof(size_t));++ switch(GETTY(heap_item)) {+ case CON:+ {+ int ar = ARITY(heap_item);+ int i = 0;+ for(i = 0; i < ar; ++i) {+ VAL ptr = heap_item->info.c.args[i];++ if (is_valid_ref(ptr)) {+ // Check for closure.+ if (!ref_in_heap(heap, ptr)) {+ fprintf(stderr, + "RTS ERROR: heap closure broken. "\+ "<HEAP %p %p %p> <REF %p>\n",+ heap->heap, heap->next, heap->end, ptr);+ exit(EXIT_FAILURE);+ }+#if 0 // TODO macro+ // Check for unidirectionality.+ if (!(ptr < heap_item)) {+ fprintf(stderr, + "RTS ERROR: heap unidirectionality broken:" \+ "<CON %p> <FIELD %p>\n",+ heap_item, ptr);+ exit(EXIT_FAILURE);+ }+#endif+ }+ }+ break;+ }+ case FWD:+ // Check for artifacts after cheney gc.+ fprintf(stderr, "RTS ERROR: FWD in working heap.\n");+ exit(EXIT_FAILURE);+ break;+ default:+ break;+ }+ }+}++void heap_check_all(Heap * heap)+{+ heap_check_underflow(heap);+ heap_check_overflow(heap);+ heap_check_pointers(heap);+}
+ rts/idris_heap.h view
@@ -0,0 +1,29 @@+#ifndef _IDRIS_HEAP_H+#define _IDRIS_HEAP_H++#include <stddef.h>++typedef struct {+ char* next; // Next allocated chunk. Should always (heap <= next < end).+ char* heap; // Point to bottom of heap+ char* end; // Point to top of heap+ size_t size; // Size of _next_ heap. Size of current heap is /end - heap/.+ size_t growth; // Quantity of heap growth in bytes. ++ char* old;+} Heap;+++void alloc_heap(Heap * heap, size_t heap_size);+void free_heap(Heap * heap);+++#ifdef IDRIS_DEBUG+void heap_check_all(Heap * heap);+// Should be used _between_ gc's.+#define HEAP_CHECK(vm) heap_check_all(&(vm->heap));+#else+#define HEAP_CHECK(vm) +#endif // IDRIS_DEBUG++#endif // _IDRIS_HEAP_H
rts/idris_main.c view
@@ -1,9 +1,30 @@+#include "idris_opts.h"+#include "idris_stats.h"+#include "idris_rts.h"+// The default options should give satisfactory results under many circumstances.+RTSOpts opts = { + .init_heap_size = 4096000,+ .max_stack_size = 4096000,+ .show_summary = 0+};+ int main(int argc, char* argv[]) {- VM* vm = init_vm(4096000, 4096000, 1, argc, argv); // 1024000);+ parse_shift_args(&opts, &argc, &argv);+ + VM* vm = init_vm(opts.max_stack_size, opts.init_heap_size, 1, argc, argv); _idris__123_runMain0_125_(vm, NULL);- //_idris_main(vm, NULL);-#ifdef IDRIS_TRACE- idris_gcInfo(vm, 1);++#ifdef IDRIS_DEBUG+ if (opts.show_summary) {+ idris_gcInfo(vm, 1);+ } #endif- terminate(vm);++ Stats stats = terminate(vm);++ if (opts.show_summary) {+ print_stats(&stats);+ }++ return EXIT_SUCCESS; }
+ rts/idris_opts.c view
@@ -0,0 +1,110 @@+#include "idris_opts.h"++#include <stdlib.h>+#include <stddef.h>+#include <stdio.h>+#include <string.h>+++char usage[] = + "\n" \+ "Usage: <prog> [+RTS <rtsopts> -RTS] <args>\n\n" \+ "Options:\n\n" \+ " -? Print this message and exits.\n" \+ " -s Summary GC statistics.\n" \+ " -H Initial heap size. Egs: -H4M, -H500K, -H1G\n" \+ " -K Sets the maximum stack size. Egs: -K8M\n" \+ "\n";++void print_usage(FILE * s) {+ fprintf(s, usage);+}++int read_size(char * str) {+ int size = 0;+ char mult = ' ';++ int r = sscanf(str, "%u%c", &size, &mult);++ if (r == 1) + return size;++ if (r == 2) {+ switch (mult) {+ case 'K': size = size << 10; break;+ case 'M': size = size << 20; break;+ case 'G': size = size << 30; break;+ default: + fprintf(stderr, + "RTS Opts: Unable to recognize size suffix `%c'.\n" \+ " Possible suffixes are K or M or G.\n",+ mult);+ print_usage(stderr);+ exit(EXIT_FAILURE);+ }+ return size;+ }++ fprintf(stderr, "RTS Opts: Unable to parse size. Egs: 1K, 10M, 2G.\n");+ print_usage(stderr);+ exit(EXIT_FAILURE);+}+++int parse_args(RTSOpts * opts, int argc, char *argv[])+{+ if (argc == 0)+ return 0;++ if (strcmp(argv[0], "+RTS") != 0)+ return 0;+ + int i;+ for (i = 1; i < argc; i++) {+ if (strcmp(argv[i], "-RTS") == 0) {+ return i + 1;+ }++ if (argv[i][0] != '-') {+ fprintf(stderr, "RTS options should start with '-'.\n");+ print_usage(stderr);+ exit(EXIT_FAILURE);+ }++ switch (argv[i][1])+ {+ case '?':+ print_usage(stdout);+ exit(EXIT_SUCCESS);+ break;++ case 's':+ opts->show_summary = 1;+ break;++ case 'H':+ opts->init_heap_size = read_size(argv[i] + 2);+ break;++ case 'K':+ opts->max_stack_size = read_size(argv[i] + 2);+ break;++ default:+ printf("RTS opts: Wrong argument: %s\n", argv[i]);+ print_usage(stderr);+ exit(EXIT_FAILURE);+ }+ }++ return argc;+}++void parse_shift_args(RTSOpts * opts, int * argc, char ** argv[]) {+ size_t shift = parse_args(opts, (*argc) - 1, (*argv) + 1);++ char *prg = (*argv)[0];+ *argc = *argc - shift;+ *argv = *argv + shift;+ (*argv)[0] = prg;+}
+ rts/idris_opts.h view
@@ -0,0 +1,19 @@+#ifndef _IDRIS_OPTS_H+#define _IDRIS_OPTS_H++#include <stddef.h>+#include <stdio.h>++typedef struct {+ size_t init_heap_size;+ size_t max_stack_size;+ int show_summary;+} RTSOpts;++void print_usage(FILE * s);++// Parse rts options and shift arguments such that rts options becomes invisible+// for main program.+void parse_shift_args(RTSOpts * opts, int * argc, char ** argv[]);++#endif
rts/idris_rts.c view
@@ -10,30 +10,24 @@ #include "idris_gc.h" #include "idris_bitstring.h" + VM* init_vm(int stack_size, size_t heap_size, int max_threads, // not implemented yet int argc, char* argv[]) {- VAL* valstack = malloc(stack_size*sizeof(VAL));- int* intstack = malloc(stack_size*sizeof(int));- double* floatstack = malloc(stack_size*sizeof(double)); VM* vm = malloc(sizeof(VM));+ STATS_INIT_STATS(vm->stats)+ STATS_ENTER_INIT(vm->stats)++ VAL* valstack = malloc(stack_size * sizeof(VAL));+ vm->valstack = valstack; vm->valstack_top = valstack; vm->valstack_base = valstack;- vm->intstack = intstack;- vm->intstack_ptr = intstack;- vm->floatstack = floatstack;- vm->floatstack_ptr = floatstack; vm->stack_max = valstack + stack_size;- vm->heap = malloc(heap_size);- vm->oldheap = NULL;- vm->heap_next = vm->heap;- vm->heap_end = vm->heap + heap_size;- vm->heap_size = heap_size;- vm->collections = 0;- vm->allocations = 0;- vm->heap_growth = heap_size;++ alloc_heap(&(vm->heap), heap_size);+ vm->ret = NULL; vm->reg1 = NULL; @@ -51,34 +45,32 @@ vm->max_threads = max_threads; vm->processes = 0; - int i;- // Assumption: there's enough space for this in the initial heap.- vm->argv = malloc(argc*sizeof(VAL));+ vm->argv = argv; vm->argc = argc; - for(i = 0; i < argc; ++i) {- vm->argv[i] = MKSTR(vm, argv[i]);- }-+ STATS_LEAVE_INIT(vm->stats) return vm; } -void terminate(VM* vm) {+Stats terminate(VM* vm) {+ Stats stats = vm->stats;+ STATS_ENTER_EXIT(stats)+ free(vm->inbox); free(vm->valstack);- free(vm->intstack);- free(vm->floatstack);- free(vm->heap);- free(vm->argv);- if (vm->oldheap != NULL) { free(vm->oldheap); }+ free_heap(&(vm->heap));+ pthread_mutex_destroy(&(vm -> inbox_lock)); pthread_mutex_destroy(&(vm -> inbox_block)); pthread_cond_destroy(&(vm -> inbox_waiting)); free(vm);++ STATS_LEAVE_EXIT(stats)+ return stats; } void idris_requireAlloc(VM* vm, size_t size) {- if (!(vm -> heap_next + size < vm -> heap_end)) {+ if (!(vm->heap.next + size < vm->heap.end)) { idris_gc(vm); } @@ -106,12 +98,19 @@ if ((size & 7)!=0) { size = 8 + ((size >> 3) << 3); }- if (vm -> heap_next + size < vm -> heap_end) {- vm->allocations += size + sizeof(size_t);- void* ptr = (void*)(vm->heap_next + sizeof(size_t));- *((size_t*)(vm->heap_next)) = size + sizeof(size_t);- vm -> heap_next += size + sizeof(size_t);+ + size_t chunk_size = size + sizeof(size_t);++ if (vm->heap.next + chunk_size < vm->heap.end) {+ STATS_ALLOC(vm->stats, chunk_size)+ void* ptr = (void*)(vm->heap.next + sizeof(size_t));+ *((size_t*)(vm->heap.next)) = chunk_size;+ vm->heap.next += chunk_size;++ assert(vm->heap.next <= vm->heap.end);+ memset(ptr, 0, size);+ if (lock) { // not message passing pthread_mutex_unlock(&vm->alloc_lock); }@@ -187,6 +186,34 @@ return cl; } +VAL MKB8(VM* vm, uint8_t bits8) {+ Closure* cl = allocate(vm, sizeof(Closure), 1);+ SETTY(cl, BITS8);+ cl -> info.bits8 = bits8;+ return cl;+}++VAL MKB16(VM* vm, uint16_t bits16) {+ Closure* cl = allocate(vm, sizeof(Closure), 1);+ SETTY(cl, BITS16);+ cl -> info.bits16 = bits16;+ return cl;+}++VAL MKB32(VM* vm, uint32_t bits32) {+ Closure* cl = allocate(vm, sizeof(Closure), 1);+ SETTY(cl, BITS32);+ cl -> info.bits32 = bits32;+ return cl;+}++VAL MKB64(VM* vm, uint64_t bits64) {+ Closure* cl = allocate(vm, sizeof(Closure), 1);+ SETTY(cl, BITS64);+ cl -> info.bits64 = bits64;+ return cl;+}+ void PROJECT(VM* vm, VAL r, int loc, int arity) { int i; for(i = 0; i < arity; ++i) {@@ -208,7 +235,7 @@ for (root = vm->valstack; root < vm->valstack_top; ++root, ++i) { printf("%d: ", i); dumpVal(*root);- if (*root >= (VAL)(vm->heap) && *root < (VAL)(vm->heap_end)) { printf("OK"); }+ if (*root >= (VAL)(vm->heap.heap) && *root < (VAL)(vm->heap.end)) { printf("OK"); } printf("\n"); } printf("RET: ");@@ -244,6 +271,22 @@ } +void idris_memset(void* ptr, i_int offset, uint8_t c, i_int size) {+ memset(((uint8_t*)ptr) + offset, c, size);+}++uint8_t idris_peek(void* ptr, i_int offset) {+ return *(((uint8_t*)ptr) + offset);+}++void idris_poke(void* ptr, i_int offset, uint8_t data) {+ *(((uint8_t*)ptr) + offset) = data;+}++void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {+ memmove(dest + dest_offset, src + src_offset, size);+}+ VAL idris_castIntStr(VM* vm, VAL i) { Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*16, 0); SETTY(cl, STRING);@@ -401,12 +444,14 @@ callvm->processes--; free(td);- terminate(vm);++ Stats stats = terminate(vm);+ // aggregate_stats(&(td->vm->stats), &stats); return NULL; } void* vmThread(VM* callvm, func f, VAL arg) {- VM* vm = init_vm(callvm->stack_max - callvm->valstack, callvm->heap_size, + VM* vm = init_vm(callvm->stack_max - callvm->valstack, callvm->heap.size, callvm->max_threads, 0, NULL); vm->processes=1; // since it can send and receive messages@@ -493,12 +538,12 @@ // So: we try to copy, if a collection happens, we do the copy again // under the assumption there's enough space this time. - int gcs = dest->collections;+ int gcs = dest->stats.collections; pthread_mutex_lock(&dest->alloc_lock); VAL dmsg = copyTo(dest, msg); pthread_mutex_unlock(&dest->alloc_lock); - if (dest->collections>gcs) {+ if (dest->stats.collections > gcs) { // a collection will have invalidated the copy pthread_mutex_lock(&dest->alloc_lock); dmsg = copyTo(dest, msg); // try again now there's room...@@ -576,11 +621,10 @@ } VAL idris_getArg(VM* vm, int i) {- return vm->argv[i];+ return MKSTR(vm, vm->argv[i]); } void stackOverflow() { fprintf(stderr, "Stack overflow"); exit(-1); }-
rts/idris_rts.h view
@@ -9,6 +9,9 @@ #include <pthread.h> #include <stdint.h> +#include "idris_heap.h"+#include "idris_stats.h"+ // Closures typedef enum {@@ -41,18 +44,12 @@ typedef struct { VAL* valstack;- int* intstack;- double* floatstack; VAL* valstack_top; VAL* valstack_base;- int* intstack_ptr;- double* floatstack_ptr;- char* heap;- char* oldheap;- char* heap_next;- char* heap_end; VAL* stack_max;- + + Heap heap;+ pthread_mutex_t inbox_lock; pthread_mutex_t inbox_block; pthread_mutex_t alloc_lock;@@ -66,14 +63,12 @@ int processes; // Number of child processes int max_threads; // maximum number of threads to run in parallel+ + Stats stats; int argc;- VAL* argv; // command line arguments+ char** argv; // command line arguments - size_t heap_size;- size_t heap_growth;- int allocations;- int collections; VAL ret; VAL reg1; } VM;@@ -83,7 +78,7 @@ int max_threads, int argc, char* argv[]); // Clean up a VM once it's no longer needed-void terminate(VM* vm);+Stats terminate(VM* vm); // Functions all take a pointer to their VM, and previous stack base, // and return nothing.@@ -130,6 +125,7 @@ #define ISINT(x) ((((i_int)x)&1) == 1) #define INTOP(op,x,y) MKINT((i_int)((((i_int)x)>>1) op (((i_int)y)>>1)))+#define UINTOP(op,x,y) MKINT((i_int)((((uintptr_t)x)>>1) op (((uintptr_t)y)>>1))) #define FLOATOP(op,x,y) MKFLOAT(vm, ((GETFLOAT(x)) op (GETFLOAT(y)))) #define FLOATBOP(op,x,y) MKINT((i_int)(((GETFLOAT(x)) op (GETFLOAT(y))))) #define ADD(x,y) (void*)(((i_int)x)+(((i_int)y)-1))@@ -152,6 +148,10 @@ VAL MKFLOAT(VM* vm, double val); VAL MKSTR(VM* vm, char* str); VAL MKPTR(VM* vm, void* ptr);+VAL MKB8(VM* vm, uint8_t b);+VAL MKB16(VM* vm, uint16_t b);+VAL MKB32(VM* vm, uint32_t b);+VAL MKB64(VM* vm, uint64_t b); // following versions don't take a lock when allocating VAL MKFLOATc(VM* vm, double val);@@ -206,6 +206,12 @@ VAL idris_castStrInt(VM* vm, VAL i); VAL idris_castFloatStr(VM* vm, VAL i); VAL idris_castStrFloat(VM* vm, VAL i);++// Raw memory manipulation+void idris_memset(void* ptr, i_int offset, uint8_t c, i_int size);+uint8_t idris_peek(void* ptr, i_int offset);+void idris_poke(void* ptr, i_int offset, uint8_t data);+void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size); // String primitives
+ rts/idris_stats.c view
@@ -0,0 +1,68 @@+#include "idris_stats.h"++#include <stdio.h>+#include <locale.h>++#ifdef IDRIS_ENABLE_STATS++void print_stats(const Stats * stats) {+ clock_t total = clock() - stats->start_time;+ clock_t mut = total - stats->init_time - stats->gc_time - stats->exit_time;+ double mut_sec = (double)mut / CLOCKS_PER_SEC;++ int avg_chunk = 0;+ if (stats->alloc_count > 0) {+ avg_chunk = (int)((double)stats->allocations / (double)stats->alloc_count);+ }++ int alloc_rate = 0;+ if (mut > 0) {+ alloc_rate = (int)((double)(stats->allocations) / mut_sec);+ }+ + double gc_percent = 0.0;+ double productivity = 0.0;+ if (total > 0) {+ gc_percent = 100 * (double)stats->gc_time / (double)total;+ productivity = 100 * ((double)mut / (double)total);+ }++ setlocale(LC_NUMERIC, "");+ printf("\n");+ printf("%'20d bytes allocated in the heap\n", stats->allocations);+ printf("%'20d bytes copied during GC\n", stats->copied);+ printf("%'20d maximum heap size\n", stats->max_heap_size);+ printf("%'20d chunks allocated in the heap\n", stats->alloc_count);+ printf("%'20d average chunk size\n\n", avg_chunk);++ printf("GC called %d times\n\n", stats->collections);++ printf("INIT time: %8.3fs\n", (double)stats->init_time / CLOCKS_PER_SEC);+ printf("MUT time: %8.3fs\n", mut_sec);+ printf("GC time: %8.3fs\n", (double)stats->gc_time / CLOCKS_PER_SEC);+ printf("EXIT time: %8.3fs\n", (double)stats->exit_time / CLOCKS_PER_SEC);+ printf("TOTAL time: %8.3fs\n\n", (double)total / CLOCKS_PER_SEC);++ printf("%%GC time: %.2f%%\n\n", gc_percent);++ printf("Alloc rate %'d bytes per MUT sec\n\n", alloc_rate);++ printf("Productivity %.2f%%\n", productivity);+}++void aggregate_stats(Stats * stats1, const Stats * stats2) {+ fprintf(stderr, "RTS error: aggregate_stats not implemented");+}++#else++void print_stats(const Stats * stats) {+ fprintf(stderr, "RTS ERROR: Stats are disabled.\n" \+ "By the way GC called %d times.\n", stats->collections);+}++void aggregate_stats(Stats * stats1, const Stats * stats2) {+ stats1->collections += stats2->collections;+}++#endif // IDRIS_ENABLE_STATS
+ rts/idris_stats.h view
@@ -0,0 +1,73 @@+#ifndef _IDRIS_STATS_H+#define _IDRIS_STATS_H++#include <time.h>++// Should not be defined in release.+#define IDRIS_ENABLE_STATS++// TODO: measure user time, exclusive/inclusive stats+typedef struct {+#ifdef IDRIS_ENABLE_STATS+ int allocations; // Size of allocated space in bytes for all execution time.+ int alloc_count; // How many times alloc is called.+ int copied; // Size of space copied during GC.+ int max_heap_size; // Maximum heap size achieved.++ clock_t init_time; // Time spent for vm initialization.+ clock_t exit_time; // Time spent for vm termination.+ clock_t gc_time; // Time spent for gc for all execution time.+ clock_t max_gc_pause; // Time spent for longest gc.+ clock_t start_time; // Time of rts entry point.+#endif // IDRIS_ENABLE_STATS+ int collections; // How many times gc called.+} Stats; // without start time it's a monoid, can we remove start_time it somehow?++void print_stats(const Stats * stats);+void aggregate_stats(Stats * stats1, const Stats * stats2);+++#ifdef IDRIS_ENABLE_STATS++#ifndef MAX+#define MAX(a, b) ((a) > (b) ? (a) : (b))+#endif++#define STATS_INIT_STATS(stats) \+ memset(&stats, 0, sizeof(Stats)); \+ stats.start_time = clock(); ++#define STATS_ALLOC(stats, size) \+ stats.allocations += size; \+ stats.alloc_count = stats.alloc_count + 1;++#define STATS_ENTER_INIT(stats) clock_t _start_time = clock();+#define STATS_LEAVE_INIT(stats) stats.init_time = clock() - _start_time;++#define STATS_ENTER_EXIT(stats) clock_t _start_time = clock();+#define STATS_LEAVE_EXIT(stats) stats.exit_time = clock() - _start_time;++#define STATS_ENTER_GC(stats, heap_size) \+ clock_t _start_time = clock(); \+ stats.max_heap_size = MAX(stats.max_heap_size, heap_size);+#define STATS_LEAVE_GC(stats, heap_size, heap_occuped) \+ clock_t _pause = clock() - _start_time; \+ stats.gc_time += _pause; \+ stats.max_gc_pause = MAX(_pause, stats.max_gc_pause); \+ stats.max_heap_size = MAX(stats.max_heap_size, heap_size); \+ stats.copied += heap_occuped; \+ stats.collections = stats.collections + 1;++#else+#define STATS_INIT_STATS(stats) memset(&stats, 0, sizeof(Stats));+#define STATS_ENTER_INIT(stats) +#define STATS_LEAVE_INIT(stats) +#define STATS_ENTER_EXIT(stats)+#define STATS_LEAVE_EXIT(stats)+#define STATS_ALLOC(stats, size)+#define STATS_ENTER_GC(stats, heap_size)+#define STATS_LEAVE_GC(stats, heap_size, heap_occuped) \+ stats.collections = stats.collections + 1;+#endif // IDRIS_ENABLE_STATS++#endif // _IDRIS_STATS_H
rts/idris_stdfgn.h view
@@ -8,7 +8,6 @@ void* fileOpen(char* f, char* mode); void fileClose(void* h);-//char* freadStr(void* h); void fputStr(void*h, char* str); int isNull(void* ptr);
rts/libidris_rts.a view
binary file changed (52032 → 64872 bytes)
src/Core/CaseTree.hs view
@@ -14,11 +14,11 @@ data CaseDef = CaseDef [Name] SC [Term] deriving Show -data SC' t = Case Name [CaseAlt' t] -- invariant: lowest tags first- | ProjCase t [CaseAlt' t] -- special case for projections+data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first+ | ProjCase t [CaseAlt' t] -- ^ special case for projections | STerm t- | UnmatchedCase String -- error message- | ImpossibleCase -- already checked to be impossible+ | UnmatchedCase String -- ^ error message+ | ImpossibleCase -- ^ already checked to be impossible deriving (Eq, Ord, Functor) {-! deriving instance Binary SC @@ -167,9 +167,15 @@ simpleCase :: Bool -> Bool -> Phase -> FC -> [([Name], Term, Term)] -> TC CaseDef-simpleCase tc cover phase fc [] +simpleCase tc cover phase fc cs+ = sc' tc cover phase fc (filter (\(_, _, r) -> + case r of+ Impossible -> False+ _ -> True) cs) + where+ sc' tc cover phase fc [] = return $ CaseDef [] (UnmatchedCase "No pattern clauses") []-simpleCase tc cover phase fc cs + sc' tc cover phase fc cs = let proj = phase == RunTime pats = map (\ (avs, l, r) -> (avs, toPats tc l, (l, r))) cs@@ -345,10 +351,13 @@ return (newArgs, addRs rs) where getNewVars [] = return []- getNewVars ((PV n) : ns) = do v <- getVar+ getNewVars ((PV n) : ns) = do v <- getVar "e" nsv <- getNewVars ns return (v : nsv)- getNewVars (_ : ns) = do v <- getVar+ getNewVars (PAny : ns) = do v <- getVar "i"+ nsv <- getNewVars ns+ return (v : nsv)+ getNewVars (_ : ns) = do v <- getVar "e" nsv <- getNewVars ns return (v : nsv) addRs [] = []@@ -357,8 +366,8 @@ uniq i (UN n) = MN i n uniq i n = n -getVar :: State CS Name-getVar = do (t, v) <- get; put (t, v+1); return (MN v "e")+getVar :: String -> State CS Name+getVar b = do (t, v) <- get; put (t, v+1); return (MN v b) groupCons :: [Clause] -> State CS [Group] groupCons cs = gc [] cs@@ -387,10 +396,12 @@ do let alts' = map (repVar v) alts match vs alts' err where- repVar v (PV p : ps , (lhs, res)) = (ps, (lhs, subst p (P Bound v Erased) res))+ repVar v (PV p : ps , (lhs, res)) + = (ps, (lhs, subst p (P Bound v Erased) res)) repVar v (PAny : ps , res) = (ps, res) -- fix: case e of S k -> f (S k) ==> case e of S k -> f e+ depatt :: [Name] -> SC -> SC depatt ns tm = dp [] tm where@@ -413,8 +424,9 @@ | and ((length args == length args') : (n == cn) : zipWith same args args') = P Ref x Erased | otherwise = applyMap ms nt cn pty args'- same n (P _ n' _) = n == n'+ same n (P _ n' _) = n == n' same _ _ = False+ applyMaps ms (App f a) = App (applyMaps ms f) (applyMaps ms a) applyMaps ms t = t
src/Core/CoreParser.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Core.CoreParser(parseTerm, parseFile, parseDef, pTerm, iName, - idrisLexer, maybeWithNS, pDocComment) where+ idrisLexer, maybeWithNS, pDocComment, opChars) where import Core.TT @@ -31,7 +31,7 @@ = ["let", "in", "data", "codata", "record", "Type", "do", "dsl", "import", "impossible", "case", "of", "total", "partial", "mutual",- "infix", "infixl", "infixr", + "infix", "infixl", "infixr", "rewrite", "where", "with", "syntax", "proof", "postulate", "using", "namespace", "class", "instance", "public", "private", "abstract", "implicit",@@ -39,8 +39,11 @@ "Bits8", "Bits16", "Bits32", "Bits64"] } -iOpStart = oneOf ":!#$%&*+./<=>?@\\^|-~"-iOpLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"+-- | The characters allowed in operator names+opChars = ":!#$%&*+./<=>?@\\^|-~"++iOpStart = oneOf opChars+iOpLetter = oneOf opChars -- <|> letter idrisLexer :: TokenParser a@@ -463,7 +466,7 @@ number base baseDigit = do{ digits <- many1 baseDigit- ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits+ ; let n = foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 digits ; seq n (return n) }
src/Core/Elaborate.hs view
@@ -171,7 +171,7 @@ if isInj ctxt tm then return () else lift $ tfail (NotInjective tm l r) where isInj ctxt (P _ n _) - | isConName Nothing n ctxt = True+ | isConName n ctxt = True isInj ctxt (App f a) = isInj ctxt f isInj ctxt (Constant _) = True isInj ctxt (TType _) = True@@ -210,7 +210,7 @@ uniqueNameCtxt :: Context -> Name -> [Name] -> Elab' aux Name uniqueNameCtxt ctxt n hs | n `elem` hs = uniqueNameCtxt ctxt (nextName n) hs- | [_] <- lookupTy Nothing n ctxt = uniqueNameCtxt ctxt (nextName n) hs+ | [_] <- lookupTy n ctxt = uniqueNameCtxt ctxt (nextName n) hs | otherwise = return n elog :: String -> Elab' aux ()@@ -356,7 +356,7 @@ mkClaims _ _ _ _ | Var n <- fn = do ctxt <- get_context- case lookupTy Nothing n ctxt of+ case lookupTy n ctxt of [] -> lift $ tfail $ NoSuchVariable n _ -> fail $ "Too many arguments for " ++ show fn | otherwise = fail $ "Too many arguments for " ++ show fn@@ -391,10 +391,13 @@ else map fst (filter (not.snd) (zip args (map fst imps))) let (n, hunis) = -- trace ("AVOID UNIFY: " ++ show (fn, dont) ++ "\n" ++ show ptm) $ - unified p+ unified p let unify = -- trace ("Not done " ++ show hs) $ - dropGiven dont hunis hs- put (ES (p { dontunify = dont, unified = (n, unify) }, a) s prev)+ dropGiven dont hunis hs+ let notunify = -- trace ("Not done " ++ show hs) $ + keepGiven dont hunis hs+ put (ES (p { dontunify = dont, unified = (n, unify),+ notunified = notunify ++ notunified p }, a) s prev) ptm <- get_term g <- goal -- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $ @@ -469,10 +472,27 @@ mkMN n@(UN x) = MN 1000 x mkMN (NS n ns) = NS (mkMN n) ns +-- If the goal is not a Pi-type, invent some names and make it a pi type+checkPiGoal :: Elab' aux ()+checkPiGoal = do g <- goal+ case g of+ Bind _ (Pi _) _ -> return ()+ _ -> do a <- unique_hole (MN 0 "argTy")+ b <- unique_hole (MN 0 "retTy")+ f <- unique_hole (MN 0 "f")+ claim a RType+ claim b RType+ claim f (RBind (MN 0 "aX") (Pi (Var a)) (Var b))+ movelast a+ movelast b+ fill (Var f)+ solve+ focus f+ simple_app :: Elab' aux () -> Elab' aux () -> Elab' aux () simple_app fun arg =- do a <- unique_hole (MN 0 "a")- b <- unique_hole (MN 0 "b")+ do a <- unique_hole (MN 0 "argTy")+ b <- unique_hole (MN 0 "retTy") f <- unique_hole (MN 0 "f") s <- unique_hole (MN 0 "s") claim a RType@@ -508,6 +528,19 @@ claim ty RType forall n (Var ty) +-- try a tactic, if it adds any unification problem, return an error+no_errors :: Elab' aux () -> Elab' aux ()+no_errors tac + = do ps <- get_probs+ tac+ ps' <- get_probs+ if (length ps' > length ps) then+ case reverse ps' of+ ((x,y,env,err) : _) ->+ let env' = map (\(x, b) -> (x, binderTy b)) env in+ lift $ tfail $ CantUnify False x y err env' 0+ else return ()+ -- Try a tactic, if it fails, try another try :: Elab' aux a -> Elab' aux a -> Elab' aux a try t1 t2 = try' t1 t2 False@@ -516,9 +549,9 @@ try' t1 t2 proofSearch = do s <- get ps <- get_probs- case prunStateT ps t1 s of- OK (v, s') -> do put s'- return v+ case prunStateT 999999 False ps t1 s of+ OK ((v, _), s') -> do put s'+ return v Error e1 -> if recoverableErr e1 then do case runStateT t2 s of OK (v, s') -> do put s'; return v@@ -539,42 +572,51 @@ -- Try a selection of tactics. Exactly one must work, all others must fail tryAll :: [(Elab' aux a, String)] -> Elab' aux a-tryAll xs = tryAll' [] (cantResolve, 0) (map fst xs)+tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs) where cantResolve :: Elab' aux a cantResolve = lift $ tfail $ CantResolveAlts (map snd xs) tryAll' :: [Elab' aux a] -> -- successes+ Int -> -- most problems (Elab' aux a, Int) -> -- smallest failure [Elab' aux a] -> -- still to try Elab' aux a- tryAll' [res] _ [] = res- tryAll' (_:_) _ [] = cantResolve- tryAll' [] (f, _) [] = f- tryAll' cs f (x:xs) + tryAll' [res] pmax _ [] = res+ tryAll' (_:_) pmax _ [] = cantResolve+ tryAll' [] pmax (f, _) [] = f+ tryAll' cs pmax f (x:xs) = do s <- get ps <- get_probs- case prunStateT ps x s of- OK (v, s') -> tryAll' ((do put s'- return v):cs) f xs+ case prunStateT pmax True ps x s of+ OK ((v, newps), s') -> + do let cs' = if (newps < pmax) + then [do put s'; return v]+ else (do put s'; return v) : cs+ tryAll' cs' newps f xs Error err -> do put s if (score err) < 100- then tryAll' cs (better err f) xs- else tryAll' [] (better err f) xs -- give up+ then tryAll' cs pmax (better err f) xs+ else tryAll' [] pmax (better err f) xs -- give up better err (f, i) = let s = score err in if (s >= i) then (lift (tfail err), s) else (f, i) -prunStateT ps x s +prunStateT pmax zok ps x s = case runStateT x s of OK (v, s'@(ES (p, _) _ _)) -> - if (length (problems p) > length ps)+ let newps = length (problems p) - length ps + newpmax = if newps < 0 then 0 else newps in+ if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0)) then case reverse (problems p) of ((_,_,_,e):_) -> Error e- else OK (v, s')+ else OK ((v, newpmax), s') Error e -> Error e++qshow :: Fails -> String+qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs) dumpprobs [] = "" dumpprobs ((_,_,_,e):es) = show e ++ "\n" ++ dumpprobs es
src/Core/Evaluate.hs view
@@ -9,7 +9,7 @@ addDatatype, addCasedef, simplifyCasedef, addOperator, lookupNames, lookupTy, lookupP, lookupDef, lookupVal, lookupTotal, lookupTyEnv, isConName, isFnName,- Value(..)) where+ Value(..), Quote(..), evalState, initEval) where import Debug.Trace import Control.Monad.State@@ -91,8 +91,9 @@ simplify :: Context -> Bool -> Env -> TT Name -> TT Name simplify ctxt runtime env t = evalState (do val <- eval False ctxt [(UN "lazy", 0),- (UN "par", 0),- (UN "fork", 0)] + (UN "assert_smaller", 0),+ (UN "par", 0),+ (UN "fork", 0)] (map finalEntry env) (finalise t) [Simplify runtime] quote 0 val) initEval@@ -149,7 +150,7 @@ ev ntimes_in stk top env (P Ref n ty) | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty) | (True, ntimes) <- usable simpl n ntimes_in- = do let val = lookupDefAcc Nothing n atRepl ctxt + = do let val = lookupDefAcc n atRepl ctxt case val of [(Function _ tm, Public)] -> ev ntimes (n:stk) True env tm@@ -220,7 +221,7 @@ _ -> return $ unload env f args | (True, ntimes) <- usable simpl n ntimes_in = traceWhen traceon (show stk) $- do let val = lookupDefAcc Nothing n atRepl ctxt+ do let val = lookupDefAcc n atRepl ctxt case val of [(CaseOp inl inr _ _ _ ns tree _ _, acc)] | acc == Public -> -- unoptimised version@@ -243,7 +244,7 @@ apply ntimes stk top env f [] = return f -- specApply stk env f@(VP Ref n ty) args--- = case lookupCtxt Nothing n statics of+-- = case lookupCtxt n statics of -- [as] -> if or as -- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $ -- return $ unload env f args@@ -281,6 +282,7 @@ Just (altmap, sc) -> evTree ntimes stk top env altmap sc _ -> return Nothing _ -> return Nothing+ evTree ntimes stk top env amap ImpossibleCase = return Nothing conHeaded tm@(App _ _) | (P (DCon _ _) _ _, args) <- unApply tm = True@@ -396,7 +398,7 @@ ev :: [HNF] -> TT Name -> Eval HNF ev env (P _ n ty) | Just (Let t v) <- lookup n genv = ev env v- ev env (P Ref n ty) = case lookupDef Nothing n ctxt of+ ev env (P Ref n ty) = case lookupDef n ctxt of [Function _ t] -> ev env t [TyDecl nt ty] -> return $ HP nt n ty [CaseOp inl _ _ _ _ [] tree _ _] ->@@ -429,7 +431,7 @@ app <- apply env sc' as wknH (-1) app apply env (HP Ref n ty) args- | [CaseOp _ _ _ _ _ ns tree _ _] <- lookupDef Nothing n ctxt+ | [CaseOp _ _ _ _ _ ns tree _ _] <- lookupDef n ctxt = do c <- evCase env ns args tree case c of (Nothing, _, env') -> return $ unload env' (HP Ref n ty) args@@ -524,6 +526,12 @@ ceq ps (P xt x _) (P yt y _) | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True | otherwise = sameDefs ps x y+ ceq ps x (Bind n (Lam t) (App y (V 0))) = ceq ps x y+ ceq ps (Bind n (Lam t) (App x (V 0))) y = ceq ps x y+ ceq ps x (Bind n (Lam t) (App y (P Bound n' _)))+ | n == n' = ceq ps x y+ ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y+ | n == n' = ceq ps x y ceq ps (V x) (V y) = return (x == y) ceq ps (Bind _ xb xs) (Bind _ yb ys) = liftM2 (&&) (ceqB ps xb yb) (ceq ps xs ys)@@ -558,7 +566,7 @@ caseeq ps (UnmatchedCase _) (UnmatchedCase _) = return True caseeq ps _ _ = return False - sameDefs ps x y = case (lookupDef Nothing x ctxt, lookupDef Nothing y ctxt) of+ sameDefs ps x y = case (lookupDef x ctxt, lookupDef y ctxt) of ([Function _ xdef], [Function _ ydef]) -> ceq ((x,y):ps) xdef ydef ([CaseOp _ _ _ _ _ _ xdef _ _], @@ -662,7 +670,7 @@ uconstraints :: [UConstraint], next_tvar :: Int, definitions :: Ctxt (Def, Accessibility, Totality) - }+ } deriving Show -- | The initial empty context initContext = MkContext [] 0 emptyContext@@ -696,10 +704,10 @@ ctxt' = addDef n (d, Public, Unchecked) ctxt in c { definitions = ctxt' } -addTyDecl :: Name -> Type -> Context -> Context-addTyDecl n ty uctxt +addTyDecl :: Name -> NameType -> Type -> Context -> Context+addTyDecl n nt ty uctxt = let ctxt = definitions uctxt- ctxt' = addDef n (TyDecl Ref ty, Public, Unchecked) ctxt in+ ctxt' = addDef n (TyDecl nt ty, Public, Unchecked) ctxt in uctxt { definitions = ctxt' } addDatatype :: Datatype Name -> Context -> Context@@ -723,7 +731,7 @@ Type -> Context -> Context addCasedef n alwaysInline tcase covering asserted ps_in ps psrt ty uctxt = let ctxt = definitions uctxt- access = case lookupDefAcc Nothing n False uctxt of+ access = case lookupDefAcc n False uctxt of [(_, acc)] -> acc _ -> Public ctxt' = case (simpleCase tcase covering CompileTime (FC "" 0) ps, @@ -740,7 +748,7 @@ simplifyCasedef :: Name -> Context -> Context simplifyCasedef n uctxt = let ctxt = definitions uctxt- ctxt' = case lookupCtxt Nothing n ctxt of+ ctxt' = case lookupCtxt n ctxt of [(CaseOp inl inr ty [] ps args sc args' sc', acc, tot)] -> ctxt -- nothing to simplify (or already done...) [(CaseOp inl inr ty ps_in ps args sc args' sc', acc, tot)] ->@@ -773,40 +781,40 @@ tfst (a, _, _) = a -lookupNames :: Maybe [String] -> Name -> Context -> [Name]-lookupNames root n ctxt- = let ns = lookupCtxtName root n (definitions ctxt) in+lookupNames :: Name -> Context -> [Name]+lookupNames n ctxt+ = let ns = lookupCtxtName n (definitions ctxt) in map fst ns -lookupTy :: Maybe [String] -> Name -> Context -> [Type]-lookupTy root n ctxt - = do def <- lookupCtxt root n (definitions ctxt)+lookupTy :: Name -> Context -> [Type]+lookupTy n ctxt+ = do def <- lookupCtxt n (definitions ctxt) case tfst def of (Function ty _) -> return ty (TyDecl _ ty) -> return ty (Operator ty _ _) -> return ty (CaseOp _ _ ty _ _ _ _ _ _) -> return ty -isConName :: Maybe [String] -> Name -> Context -> Bool-isConName root n ctxt - = or $ do def <- lookupCtxt root n (definitions ctxt)+isConName :: Name -> Context -> Bool+isConName n ctxt+ = or $ do def <- lookupCtxt n (definitions ctxt) case tfst def of (TyDecl (DCon _ _) _) -> return True (TyDecl (TCon _ _) _) -> return True _ -> return False -isFnName :: Maybe [String] -> Name -> Context -> Bool-isFnName root n ctxt - = or $ do def <- lookupCtxt root n (definitions ctxt)+isFnName :: Name -> Context -> Bool+isFnName n ctxt+ = or $ do def <- lookupCtxt n (definitions ctxt) case tfst def of (Function _ _) -> return True (Operator _ _ _) -> return True (CaseOp _ _ _ _ _ _ _ _ _) -> return True _ -> return False -lookupP :: Maybe [String] -> Name -> Context -> [Term]-lookupP root n ctxt - = do def <- lookupCtxt root n (definitions ctxt)+lookupP :: Name -> Context -> [Term]+lookupP n ctxt+ = do def <- lookupCtxt n (definitions ctxt) p <- case def of (Function ty tm, a, _) -> return (P Ref n ty, a) (TyDecl nt ty, a, _) -> return (P nt n ty, a)@@ -816,22 +824,22 @@ Hidden -> [] _ -> return (fst p) -lookupDef :: Maybe [String] -> Name -> Context -> [Def]-lookupDef root n ctxt = map tfst $ lookupCtxt root n (definitions ctxt)+lookupDef :: Name -> Context -> [Def]+lookupDef n ctxt = map tfst $ lookupCtxt n (definitions ctxt) -lookupDefAcc :: Maybe [String] -> Name -> Bool -> Context -> +lookupDefAcc :: Name -> Bool -> Context -> [(Def, Accessibility)]-lookupDefAcc root n mkpublic ctxt - = map mkp $ lookupCtxt root n (definitions ctxt)+lookupDefAcc n mkpublic ctxt+ = map mkp $ lookupCtxt n (definitions ctxt) where mkp (d, a, _) = if mkpublic then (d, Public) else (d, a) lookupTotal :: Name -> Context -> [Totality]-lookupTotal n ctxt = map mkt $ lookupCtxt Nothing n (definitions ctxt)+lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt) where mkt (d, a, t) = t -lookupVal :: Maybe [String] -> Name -> Context -> [Value]-lookupVal root n ctxt - = do def <- lookupCtxt root n (definitions ctxt)+lookupVal :: Name -> Context -> [Value]+lookupVal n ctxt+ = do def <- lookupCtxt n (definitions ctxt) case tfst def of (Function _ htm) -> return (veval ctxt [] htm) (TyDecl nt ty) -> return (VP nt n (veval ctxt [] ty))
+ src/Core/Execute.hs view
@@ -0,0 +1,567 @@+{-# LANGUAGE PatternGuards, ExistentialQuantification #-}+module Core.Execute (execute) where++import Idris.AbsSyntax+import Idris.AbsSyntaxTree+import IRTS.Lang( IntTy(..)+ , intTyToConst+ , FType(..))++import Core.TT+import Core.Evaluate+import Core.CaseTree++import Debug.Trace++import Util.DynamicLinker+import Util.System++import Control.Applicative hiding (Const)+import Control.Monad.Trans+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Error+import Control.Monad+import Data.Maybe+import Data.Bits+import qualified Data.Map as M++import Foreign.LibFFI+import Foreign.C.String+import Foreign.Marshal.Alloc (free)+import Foreign.Ptr++import System.IO+++data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show++data ExecState = ExecState { exec_thunks :: M.Map Int Lazy -- ^ Thunks - the result of evaluating "lazy" or calling lazy funcs+ , exec_next_thunk :: Int -- ^ Ensure thunk key uniqueness+ , exec_implicits :: Ctxt [PArg] -- ^ Necessary info on laziness from idris monad+ , exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad+ }++data ExecVal = EP NameType Name ExecVal+ | EV Int+ | EBind Name (Binder ExecVal) (ExecVal -> Exec ExecVal)+ | EApp ExecVal ExecVal+ | EType UExp+ | EErased+ | EConstant Const+ | forall a. EPtr (Ptr a)+ | EThunk Int+ | EHandle Handle++instance Show ExecVal where+ show (EP _ n _) = show n+ show (EV i) = "!!V" ++ show i ++ "!!"+ show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"+ show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"+ show (EType _) = "Type"+ show EErased = "[__]"+ show (EConstant c) = show c+ show (EPtr p) = "<<ptr " ++ show p ++ ">>"+ show (EThunk i) = "<<thunk " ++ show i ++ ">>"+ show (EHandle h) = "<<handle " ++ show h ++ ">>"++toTT :: ExecVal -> Exec Term+toTT (EP nt n ty) = (P nt n) <$> (toTT ty)+toTT (EV i) = return $ V i+toTT (EBind n b body) = do body' <- body $ EP Bound n EErased+ b' <- fixBinder b+ Bind n b' <$> toTT body'+ where fixBinder (Lam t) = Lam <$> toTT t+ fixBinder (Pi t) = Pi <$> toTT t+ fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2+ fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2+ fixBinder (Hole t) = Hole <$> toTT t+ fixBinder (GHole t) = GHole <$> toTT t+ fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2+ fixBinder (PVar t) = PVar <$> toTT t+ fixBinder (PVTy t) = PVTy <$> toTT t+toTT (EApp e1 e2) = do e1' <- toTT e1+ e2' <- toTT e2+ return $ App e1' e2'+toTT (EType u) = return $ TType u+toTT EErased = return Erased+toTT (EConstant c) = return (Constant c)+toTT (EThunk i) = return (P (DCon 0 0) (MN i "THUNK") Erased) --(force i) >>= toTT+toTT (EHandle _) = return Erased++unApplyV :: ExecVal -> (ExecVal, [ExecVal])+unApplyV tm = ua [] tm+ where ua args (EApp f a) = ua (a:args) f+ ua args t = (t, args)++mkEApp :: ExecVal -> [ExecVal] -> ExecVal+mkEApp f [] = f+mkEApp f (a:args) = mkEApp (EApp f a) args++initState :: Idris ExecState+initState = do ist <- getIState+ return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)++type Exec = ErrorT String (StateT ExecState IO)++runExec :: Exec a -> ExecState -> IO (Either String a)+runExec ex st = fst <$> runStateT (runErrorT ex) st++getExecState :: Exec ExecState+getExecState = lift get++putExecState :: ExecState -> Exec ()+putExecState = lift . put++execFail :: String -> Exec a+execFail = throwError++execIO :: IO a -> Exec a+execIO = lift . lift++delay :: ExecEnv -> Context -> Term -> Exec ExecVal+delay env ctxt tm =+ do st <- getExecState+ let i = exec_next_thunk st+ putExecState $ st { exec_thunks = M.insert i (Delayed env ctxt tm) (exec_thunks st)+ , exec_next_thunk = exec_next_thunk st + 1+ }+ return $ EThunk i++force :: Int -> Exec ExecVal+force i = do st <- getExecState+ case M.lookup i (exec_thunks st) of+ Just (Delayed env ctxt tm) -> do tm' <- doExec env ctxt tm+ case tm' of+ EThunk i ->+ do res <- force i+ update res i+ return res+ _ -> do update tm' i+ return tm'+ Just (Forced tm) -> return tm+ Nothing -> execFail "Tried to exec non-existing thunk. This is a bug!"+ where update :: ExecVal -> Int -> Exec ()+ update tm i = do est <- getExecState+ putExecState $ est { exec_thunks = M.insert i (Forced tm) (exec_thunks est) }++tryForce :: ExecVal -> Exec ExecVal+tryForce (EThunk i) = force i+tryForce tm = return tm++debugThunks :: Exec ()+debugThunks = do st <- getExecState+ execIO $ putStrLn (take 4000 (show (exec_thunks st)))++execute :: Term -> Idris Term+execute tm = do est <- initState+ ctxt <- getContext+ res <- lift $ flip runExec est $ do res <- doExec [] ctxt tm+ toTT res+ case res of+ Left err -> fail err+ Right tm' -> return tm'++ioWrap :: ExecVal -> ExecVal+ioWrap tm = mkEApp (EP (DCon 0 2) (UN "prim__IO") EErased) [EErased, tm]++ioUnit :: ExecVal+ioUnit = ioWrap (EP Ref unitCon EErased)++type ExecEnv = [(Name, ExecVal)]++doExec :: ExecEnv -> Context -> Term -> Exec ExecVal+doExec env ctxt p@(P Ref n ty) | Just v <- lookup n env = return v+doExec env ctxt p@(P Ref n ty) =+ do let val = lookupDef n ctxt+ case val of+ [Function _ tm] -> doExec env ctxt tm+ [TyDecl _ _] -> return (EP Ref n EErased) -- abstract def+ [Operator tp arity op] -> return (EP Ref n EErased) -- will be special-cased later+ [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun+ doExec env ctxt tm+ [CaseOp _ _ _ _ _ ns sc _ _] -> return (EP Ref n EErased)+ [] -> execFail $ "Could not find " ++ show n ++ " in definitions."+ thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined+doExec env ctxt p@(P Bound n ty) =+ case lookup n env of+ Nothing -> execFail "not found"+ Just tm -> return tm+doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)+doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased)+doExec env ctxt v@(V i) | i < length env = return (snd (env !! i))+ | otherwise = execFail "env too small"+doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v+ doExec ((n, v'):env) ctxt body+doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined+doExec env ctxt tm@(Bind n b body) = return $+ EBind n (fmap (\_->EErased) b)+ (\arg -> doExec ((n, arg):env) ctxt body)+doExec env ctxt a@(App _ _) = execApp env ctxt (unApply a)+doExec env ctxt (Constant c) = return (EConstant c)+doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in+ doExec env ctxt ((x:xs) !! i)+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)++execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal+execApp env ctxt (f, args) = do newF <- doExec env ctxt f+ laziness <- (++ repeat False) <$> (getLaziness newF)+ newArgs <- mapM argExec (zip args laziness)+ execApp' env ctxt newF newArgs+ where getLaziness (EP _ (UN "lazy") _) = return [False, True]+ getLaziness (EP _ n _) = do est <- getExecState+ let argInfo = exec_implicits est+ case lookupCtxtName n argInfo of+ [] -> return (repeat False)+ [ps] -> return $ map lazyarg (snd ps)+ many -> execFail $ "Ambiguous " ++ show n ++ ", found " ++ (take 200 $ show many)+ getLaziness _ = return (repeat False) -- ok due to zip above+ argExec :: (Term, Bool) -> Exec ExecVal+ argExec (tm, False) = doExec env ctxt tm+ argExec (tm, True) = delay env ctxt tm+++execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal+execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls+execApp' env ctxt (EP _ (UN "unsafePerformIO") _) (ty:action:rest) | (prim__IO, [_, v]) <- unApplyV action =+ execApp' env ctxt v rest++execApp' env ctxt (EP _ (UN "io_bind") _) args@(_:_:v:k:rest) | (prim__IO, [_, v']) <- unApplyV v =+ do v'' <- tryForce v'+ res <- execApp' env ctxt k [v''] >>= tryForce+ execApp' env ctxt res rest+execApp' env ctxt con@(EP _ (UN "io_return") _) args@(tp:v:rest) =+ do v' <- tryForce v+ execApp' env ctxt (mkEApp con [tp, v']) rest++-- Special cases arising from not having access to the C RTS in the interpreter+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str arg):rest)+ | Just (FFun "putStr" _ _) <- foreignFromTT fn = do execIO (putStr arg)+ execApp' env ctxt ioUnit rest+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)+ | Just (FFun "fileOpen" _ _) <- foreignFromTT fn = do m <- case mode of+ "r" -> return ReadMode+ "w" -> return WriteMode+ "a" -> return AppendMode+ "rw" -> return ReadWriteMode+ "wr" -> return ReadWriteMode+ "r+" -> return ReadWriteMode+ _ -> execFail ("Invalid mode for " ++ f ++ ": " ++ mode)+ h <- execIO $ openFile f m+ execApp' env ctxt (ioWrap (EHandle h)) rest++execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)+ | Just (FFun "fileEOF" _ _) <- foreignFromTT fn = do eofp <- execIO $ hIsEOF h+ let res = ioWrap (EConstant (I $ if eofp then 1 else 0))+ execApp' env ctxt res rest++execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)+ | Just (FFun "fileClose" _ _) <- foreignFromTT fn = do execIO $ hClose h+ execApp' env ctxt ioUnit rest++execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EPtr p):rest)+ | Just (FFun "isNull" _ _) <- foreignFromTT fn = let res = ioWrap . EConstant . I $+ if p == nullPtr then 1 else 0+ in execApp' env ctxt res rest++execApp' env ctxt f@(EP _ (UN "mkForeign") _) args@(ty:fn:xs) | Just (FFun f argTs retT) <- foreignFromTT fn+ , length xs >= length argTs =+ do res <- stepForeign (ty:fn:take (length argTs) xs)+ case res of+ Nothing -> fail $ "Could not call foreign function \"" ++ f +++ "\" with args " ++ show (take (length argTs) xs)+ Just r -> return (mkEApp r (drop (length argTs) xs))+ | otherwise = return (mkEApp f args)++execApp' env ctxt f@(EP _ n _) args =+ do let val = lookupDef n ctxt+ case val of+ [Function _ tm] -> fail "should already have been eval'd"+ [TyDecl nt ty] -> return $ mkEApp f args+ [Operator tp arity op] ->+ if length args >= arity+ then do args' <- mapM tryForce $ take arity args+ case getOp n args' of+ Just res -> do r <- res+ execApp' env ctxt r (drop arity args)+ Nothing -> return (mkEApp f args)+ else return (mkEApp f args)+ [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun+ do rhs <- doExec env ctxt tm+ execApp' env ctxt rhs args+ [CaseOp _ _ _ _ _ ns sc _ _] ->+ do res <- execCase env ctxt ns sc args+ return $ fromMaybe (mkEApp f args) res+ thing -> return $ mkEApp f args+ where getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)+ getOp (UN "prim__addInt") [EConstant (I i1), EConstant (I i2)] =+ primRes I (i1 + i2)+ getOp (UN "prim__andInt") [EConstant (I i1), EConstant (I i2)] =+ primRes I (i1 .&. i2)+ getOp (UN "prim__charToInt") [EConstant (Ch c)] =+ primRes I (fromEnum c)+ getOp (UN "prim__complInt") [EConstant (I i)] =+ primRes I (complement i)+ getOp (UN "prim__concat") [EConstant (Str s1), EConstant (Str s2)] =+ primRes Str (s1 ++ s2)+ getOp (UN "prim__divInt") [EConstant (I i1), EConstant (I i2)] =+ primRes I (i1 `div` i2)+ getOp (UN "prim__eqChar") [EConstant (Ch c1), EConstant (Ch c2)] =+ primResBool (c1 == c2)+ getOp (UN "prim__eqInt") [EConstant (I i1), EConstant (I i2)] =+ primResBool (i1 == i2)+ getOp (UN "prim__eqString") [EConstant (Str s1), EConstant (Str s2)] =+ primResBool (s1 == s2)+ getOp (UN "prim__gtChar") [EConstant (Ch i1), EConstant (Ch i2)] =+ primResBool (i1 > i2)+ getOp (UN "prim__gteChar") [EConstant (Ch i1), EConstant (Ch i2)] =+ primResBool (i1 >= i2)+ getOp (UN "prim__gtInt") [EConstant (I i1), EConstant (I i2)] =+ primResBool (i1 > i2)+ getOp (UN "prim__gteInt") [EConstant (I i1), EConstant (I i2)] =+ primResBool (i1 >= i2)+ getOp (UN "prim__intToFloat") [EConstant (I i)] =+ primRes Fl (fromRational (toRational i))+ getOp (UN "prim__intToStr") [EConstant (I i)] =+ primRes Str (show i)+ getOp (UN "prim_lenString") [EConstant (Str s)] =+ primRes I (length s)+ getOp (UN "prim__ltChar") [EConstant (Ch i1), EConstant (Ch i2)] =+ primResBool (i1 < i2)+ getOp (UN "prim__lteChar") [EConstant (Ch i1), EConstant (Ch i2)] =+ primResBool (i1 <= i2)+ getOp (UN "prim__lteInt") [EConstant (I i1), EConstant (I i2)] =+ primResBool (i1 <= i2)+ getOp (UN "prim__ltInt") [EConstant (I i1), EConstant (I i2)] =+ primResBool (i1 < i2)+ getOp (UN "prim__modInt") [EConstant (I i1), EConstant (I i2)] =+ primRes I (i1 `mod` i2)+ getOp (UN "prim__mulBigInt") [EConstant (BI i1), EConstant (BI i2)] =+ primRes BI (i1 * i2)+ getOp (UN "prim__mulFloat") [EConstant (Fl i1), EConstant (Fl i2)] =+ primRes Fl (i1 * i2)+ getOp (UN "prim__mulInt") [EConstant (I i1), EConstant (I i2)] =+ primRes I (i1 * i2)+ getOp (UN "prim__orInt") [EConstant (I i1), EConstant (I i2)] =+ primRes I (i1 .|. i2)+ getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] =+ Just $ do line <- execIO getLine+ return (EConstant (Str line))+ getOp (UN "prim__readString") [EHandle h] =+ Just $ do contents <- execIO $ hGetLine h+ return (EConstant (Str contents))+ getOp (UN "prim__shLInt") [EConstant (I i1), EConstant (I i2)] =+ primRes I (shiftL i1 i2)+ getOp (UN "prim__shRInt") [EConstant (I i1), EConstant (I i2)] =+ primRes I (shiftR i1 i2)+ getOp (UN "prim__strCons") [EConstant (Ch c), EConstant (Str s)] =+ primRes Str (c:s)+ getOp (UN "prim__strHead") [EConstant (Str (c:s))] =+ primRes Ch c+ getOp (UN "prim__strRev") [EConstant (Str s)] =+ primRes Str (reverse s)+ getOp (UN "prim__strTail") [EConstant (Str (c:s))] =+ primRes Str s+ getOp (UN "prim__subFloat") [EConstant (Fl i1), EConstant (Fl i2)] =+ primRes Fl (i1 - i2)+ getOp (UN "prim__subInt") [EConstant (I i1), EConstant (I i2)] =+ primRes I (i1 - i2)+ getOp (UN "prim__xorInt") [EConstant (I i1), EConstant (I i2)] =+ primRes I (i1 `xor` i2)+ getOp n args = trace ("No prim " ++ show n ++ " for " ++ take 1000 (show args)) Nothing++ primRes :: (a -> Const) -> a -> Maybe (Exec ExecVal)+ primRes constr = Just . return . EConstant . constr++ primResBool :: Bool -> Maybe (Exec ExecVal)+ primResBool b = primRes I (if b then 1 else 0)++execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg+ let (f', as) = unApplyV ret+ execApp' env ctxt f' (as ++ args)+execApp' env ctxt (EThunk i) args = do f <- force i+ execApp' env ctxt f args+execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)+execApp' env ctxt f args = return (mkEApp f args)++++++-- | Overall wrapper for case tree execution. If there are enough arguments, it takes them,+-- evaluates them, then begins the checks for matching cases.+execCase :: ExecEnv -> Context -> [Name] -> SC -> [ExecVal] -> Exec (Maybe ExecVal)+execCase env ctxt ns sc args =+ let arity = length ns in+ if arity <= length args+ then do let amap = zip ns args+-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()+ caseRes <- execCase' env ctxt amap sc+ case caseRes of+ Just res -> Just <$> execApp' (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)+ Nothing -> return Nothing+ else return Nothing++-- | Take bindings and a case tree and examines them, executing the matching case if possible.+execCase' :: ExecEnv -> Context -> [(Name, ExecVal)] -> SC -> Exec (Maybe ExecVal)+execCase' env ctxt amap (UnmatchedCase _) = return Nothing+execCase' env ctxt amap (STerm tm) =+ Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm+execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =+ do tm' <- tryForce tm+ case chooseAlt tm' alts of+ Just (newCase, newBindings) ->+ let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in+ execCase' env ctxt amap' newCase+ Nothing -> return Nothing++chooseAlt :: ExecVal -> [CaseAlt] -> Maybe (SC, [(Name, ExecVal)])+chooseAlt _ (DefaultCase sc : alts) = Just (sc, [])+chooseAlt (EConstant c) (ConstCase c' sc : alts) | c == c' = Just (sc, [])+chooseAlt tm (ConCase n i ns sc : alts) | ((EP _ cn _), args) <- unApplyV tm+ , cn == n = Just (sc, zip ns args)+ | otherwise = chooseAlt tm alts+chooseAlt tm (_:alts) = chooseAlt tm alts+chooseAlt _ [] = Nothing+++++idrisType :: FType -> ExecVal+idrisType FUnit = EP Ref unitTy EErased+idrisType ft = EConstant (idr ft)+ where idr (FInt ty) = intTyToConst ty+ idr FDouble = FlType+ idr FChar = ChType+ idr FString = StrType+ idr FPtr = PtrType++data Foreign = FFun String [FType] FType deriving Show+++call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)+call (FFun name argTypes retType) args =+ do fn <- findForeign name+ case fn of+ Nothing -> return Nothing+ Just f -> do res <- call' f args retType+ return . Just . ioWrap $ res+ where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal+ call' (Fun _ h) args (FInt ITNative) = do res <- execIO $ callFFI h retCInt (prepArgs args)+ return (EConstant (I (fromIntegral res)))+ call' (Fun _ h) args (FInt IT8) = do res <- execIO $ callFFI h retCChar (prepArgs args)+ return (EConstant (B8 (fromIntegral res)))+ call' (Fun _ h) args (FInt IT16) = do res <- execIO $ callFFI h retCWchar (prepArgs args)+ return (EConstant (B16 (fromIntegral res)))+ call' (Fun _ h) args (FInt IT32) = do res <- execIO $ callFFI h retCInt (prepArgs args)+ return (EConstant (B32 (fromIntegral res)))+ call' (Fun _ h) args (FInt IT64) = do res <- execIO $ callFFI h retCLong (prepArgs args)+ return (EConstant (B64 (fromIntegral res)))+ call' (Fun _ h) args FDouble = do res <- execIO $ callFFI h retCDouble (prepArgs args)+ return (EConstant (Fl (realToFrac res)))+ call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args)+ return (EConstant (Ch (castCCharToChar res)))+ call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)+ hStr <- execIO $ peekCString res+-- lift $ free res+ return (EConstant (Str hStr))++ call' (Fun _ h) args FPtr = do res <- execIO $ callFFI h (retPtr retVoid) (prepArgs args)+ return (EPtr res)+ call' (Fun _ h) args FUnit = do res <- execIO $ callFFI h retVoid (prepArgs args)+ return (EP Ref unitCon EErased)+-- call' (Fun _ h) args other = fail ("Unsupported foreign return type " ++ show other)+++ prepArgs = map prepArg+ prepArg (EConstant (I i)) = argCInt (fromIntegral i)+ prepArg (EConstant (B8 i)) = argCChar (fromIntegral i)+ prepArg (EConstant (B16 i)) = argCWchar (fromIntegral i)+ prepArg (EConstant (B32 i)) = argCInt (fromIntegral i)+ prepArg (EConstant (B64 i)) = argCLong (fromIntegral i)+ prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)+ prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars+ prepArg (EConstant (Str s)) = argString s+ prepArg (EPtr p) = argPtr p+ prepArg other = trace ("Could not use " ++ take 100 (show other) ++ " as FFI arg.") undefined++++foreignFromTT :: ExecVal -> Maybe Foreign+foreignFromTT t = case (unApplyV t) of+ (_, [(EConstant (Str name)), args, ret]) ->+ do argTy <- unEList args+ argFTy <- sequence $ map getFTy argTy+ retFTy <- getFTy ret+ return $ FFun name argFTy retFTy+ _ -> trace "failed to construct ffun" Nothing++getFTy :: ExecVal -> Maybe FType+getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =+ case intTy of+ "ITNative" -> Just $ FInt ITNative+ "IT8" -> Just $ FInt IT8+ "IT16" -> Just $ FInt IT16+ "IT32" -> Just $ FInt IT32+ "IT64" -> Just $ FInt IT64+ _ -> Nothing+getFTy (EP _ (UN t) _) =+ case t of+ "FFloat" -> Just FDouble+ "FChar" -> Just FChar+ "FString" -> Just FString+ "FPtr" -> Just FPtr+ "FUnit" -> Just FUnit+ _ -> Nothing+getFTy _ = Nothing++unList :: Term -> Maybe [Term]+unList tm = case unApply tm of+ (nil, [_]) -> Just []+ (cons, ([_, x, xs])) ->+ do rest <- unList xs+ return $ x:rest+ (f, args) -> Nothing++unEList :: ExecVal -> Maybe [ExecVal]+unEList tm = case unApplyV tm of+ (nil, [_]) -> Just []+ (cons, ([_, x, xs])) ->+ do rest <- unEList xs+ return $ x:rest+ (f, args) -> Nothing+++toConst :: Term -> Maybe Const+toConst (Constant c) = Just c+toConst _ = Nothing++stepForeign :: [ExecVal] -> Exec (Maybe ExecVal)+stepForeign (ty:fn:args) = do let ffun = foreignFromTT fn+ f' <- case (call <$> ffun) of+ Just f -> f args+ Nothing -> return Nothing+ return f'+stepForeign _ = fail "Tried to call foreign function that wasn't mkForeign"++mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+mapMaybeM f [] = return []+mapMaybeM f (x:xs) = do rest <- mapMaybeM f xs+ x' <- f x+ case x' of+ Just x'' -> return (x'':rest)+ Nothing -> return rest++findForeign :: String -> Exec (Maybe ForeignFun)+findForeign fn = do est <- getExecState+ let libs = exec_dynamic_libs est+ fns <- mapMaybeM getFn libs+ case fns of+ [f] -> return (Just f)+ [] -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" not found"+ return Nothing+ fs -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" is ambiguous. Found " +++ show (length fs) ++ " occurrences."+ return Nothing+ where getFn lib = execIO $ catchIO (tryLoadFn fn lib) (\_ -> return Nothing)
src/Core/ProofShell.hs view
@@ -41,7 +41,7 @@ (state, show nf ++ " : " ++ show ty) err -> (state, show err) processCommand (Print n) state =- case lookupDef Nothing n (ctxt state) of+ case lookupDef n (ctxt state) of [tm] -> (state, show tm) _ -> (state, "No such name") processCommand (Tac e) state
src/Core/ProofState.hs view
@@ -5,7 +5,8 @@ evaluation/checking inside the proof system, etc. --} module Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,- Tactic(..), Goal(..), processTactic, dropGiven) where+ Tactic(..), Goal(..), processTactic, + dropGiven, keepGiven) where import Core.Typecheck import Core.Evaluate@@ -27,6 +28,7 @@ ptype :: Type, -- original goal dontunify :: [Name], -- explicitly given by programmer, leave it unified :: (Name, [(Name, Term)]),+ notunified :: [(Name, Term)], solved :: Maybe (Name, Term), problems :: Fails, injective :: [Name], @@ -78,8 +80,8 @@ -- Some utilites on proof and tactic states instance Show ProofState where- show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals"- show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ i _ _ ctxt _ _) + show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals"+ show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _) = let OK g = goal (Just h) tm wkenv = premises g in "Other goals: " ++ show hs ++ "\n" ++@@ -102,12 +104,12 @@ showG ps b = showEnv ps (binderTy b) instance Pretty ProofState where- pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _) =+ pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _) = if size nm > breakingSize then pretty nm <> colon $$ nest nestingSize (text " no more goals.") else pretty nm <> colon <+> text " no more goals."- pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ i _ _ ctxt _ _) =+ pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _) = let OK g = goal (Just h) tm in let wkEnv = premises g in text "Other goals" <+> colon <+> pretty hs $$@@ -155,10 +157,15 @@ unify' :: Context -> Env -> TT Name -> TT Name -> StateT TState TC [(Name, TT Name)] unify' ctxt env topx topy = do ps <- get- (u, fails) <- lift $ unify ctxt env topx topy (injective ps) (holes ps)--- trace ("Unified " ++ show (topx, topy) ++ show (injective ps) ++ --- " " ++ show u ++ "\n" ++ qshow fails ++ "\nCurrent problems:\n"--- ++ qshow (problems ps) ++ "\n" ++ show (holes ps)) $+ let dont = dontunify ps+ (u, fails) <- -- trace ("Trying " ++ show (topx, topy)) $ + lift $ unify ctxt env topx topy dont (holes ps)+-- trace ("Unified " ++ show (topx, topy) ++ " without " ++ show dont +++-- -- " in " ++ show env ++ +-- "\n" ++ show u ++ "\n" ++ qshow fails ++ "\nCurrent problems:\n"+-- ++ qshow (problems ps) ++ "\n" ++ show (holes ps) ++ "\n"+-- ++ show (pterm ps) +-- ++ "\n----------") $ case fails of -- [] -> return u err -> @@ -189,7 +196,7 @@ newProof n ctxt ty = let h = holeName 0 ty' = vToP ty in PS n [h] [] 1 (Bind h (Hole ty') - (P Bound h ty')) ty [] (h, []) + (P Bound h ty')) ty [] (h, []) [] Nothing [] [] [] [] Nothing ctxt "" False@@ -353,9 +360,8 @@ -- As exact, but attempts to solve other goals by unification fill :: Raw -> RunTactic-fill guess ctxt env (Bind x (Hole ty) sc) =+fill guess ctxt env (Bind x (Hole ty) sc) = do (val, valty) <- lift $ check ctxt env guess- s <- get -- let valtyn = normalise ctxt env valty -- let tyn = normalise ctxt env ty ns <- unify' ctxt env valty ty@@ -383,10 +389,19 @@ return $ Bind x (Guess ty val) sc complete_fill ctxt env t = fail $ "Can't complete fill at " ++ show t +-- When solving something in the 'dont unify' set, we should check+-- that the guess we are solving it with unifies with the thing unification+-- found for it, if anything.+ solve :: RunTactic solve ctxt env (Bind x (Guess ty val) sc) | True = do ps <- get let (uh, uns) = unified ps+ case lookup x (notunified ps) of+ Just tm -> do -- trace ("AVOIDED " ++ show (x, tm, val)) $ + -- return []+ unify' ctxt env tm val+ _ -> return [] action (\ps -> ps { holes = holes ps \\ [x], solved = Just (x, val), -- problems = solveInProblems @@ -396,9 +411,9 @@ instances = instances ps \\ [x] }) return $ {- Bind x (Let ty val) sc -} instantiate val (pToV x sc)- | otherwise = do ps <- get- lift $ tfail $ IncompleteTerm val-solve _ _ h = do ps <- get+ | otherwise = lift $ tfail $ IncompleteTerm val+solve _ _ h@(Bind x t sc) + = do ps <- get fail $ "Not a guess " ++ show h ++ "\n" ++ show (holes ps, pterm ps) introTy :: Raw -> Maybe Name -> RunTactic@@ -418,7 +433,7 @@ let (uh, uns) = unified ps -- put (ps { unified = (uh, uns ++ ns) }) return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t'))- _ -> fail "Nothing to introduce"+ _ -> lift $ tfail $ CantIntroduce t' introTy ty n ctxt env _ = fail "Can't introduce here." intro :: Maybe Name -> RunTactic@@ -433,14 +448,13 @@ Bind y (Pi s) t -> -- trace ("in type " ++ show t') $ let t' = instantiate (P Bound n s) (pToV y t) in return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))- _ -> fail "Nothing to introduce"+ _ -> lift $ tfail $ CantIntroduce t' intro n ctxt env _ = fail "Can't introduce here." forall :: Name -> Raw -> RunTactic forall n ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do (tyv, tyt) <- lift $ check ctxt env ty- lift $ isType ctxt env tyt- lift $ isType ctxt env t+ unify' ctxt env tyt (TType (UVar 0)) return $ Bind n (Pi tyv) (Bind x (Hole t) (P Bound x t)) forall n ty ctxt env _ = fail "Can't pi bind here" @@ -562,6 +576,15 @@ -- dropGiven du (u@(_, P a n ty) : us) | n `elem` du = dropGiven du us dropGiven du (u : us) hs = u : dropGiven du us hs +keepGiven du [] hs = []+keepGiven du ((n, P Bound t ty) : us) hs+ | n `elem` du && not (t `elem` du)+ && n `elem` hs && t `elem` hs+ = keepGiven du us hs+keepGiven du (u@(n, _) : us) hs + | n `elem` du = u : keepGiven du us hs+keepGiven du (u : us) hs = keepGiven du us hs+ updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $ updateSolved' xs x updateSolved' xs (Bind n (Hole ty) t)@@ -615,7 +638,7 @@ ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns (ns'', probs') = updateProblems (context ps) ns' (problems ps) (injective ps) (holes ps)- tm' = -- trace ("Updating " ++ show ns' ++ "\n" ++ show ns'') $ -- ++ " in " ++ show (pterm ps)) $+ tm' = -- trace ("Updating " ++ show ns_in ++ "\n" ++ show ns'') $ -- ++ " in " ++ show (pterm ps)) $ updateSolved ns'' (pterm ps) in return (ps { pterm = tm', unified = (h, []),
src/Core/TT.hs view
@@ -57,6 +57,8 @@ -- unification succeed | InfiniteUnify Name Term [(Name, Type)] | CantConvert Term Term [(Name, Type)]+ | NonFunctionType Term Term+ | CantIntroduce Term | NoSuchVariable Name | NoTypeDecl Name | NotInjective Term Term Term@@ -69,7 +71,9 @@ | NonCollapsiblePostulate Name | AlreadyDefined Name | ProofSearchFail Err+ | NoRewriting Term | At FC Err+ | ProviderError String deriving Eq instance Sized Err where@@ -82,11 +86,13 @@ size (NoTypeDecl name) = size name size (NotInjective l c r) = size l + size c + size r size (CantResolve trm) = size trm+ size (NoRewriting trm) = size trm size (CantResolveAlts _) = 1 size (IncompleteTerm trm) = size trm size UniverseError = 1 size ProgramLineComment = 1 size (At fc err) = size fc + size err+ size (ProviderError msg) = length msg size _ = 1 score :: Err -> Int@@ -102,6 +108,7 @@ show (CantUnify _ l r e sc i) = "CantUnify " ++ show l ++ " " ++ show r ++ " " ++ show e ++ " in " ++ show sc ++ " " ++ show i show (Inaccessible n) = show n ++ " is not an accessible pattern variable"+ show (ProviderError msg) = "Type provider error: " ++ msg show _ = "Error" instance Pretty Err where@@ -114,6 +121,7 @@ else text "Cannot unify" <+> colon <+> pretty l <+> text "and" <+> pretty r $$ nest nestingSize (text "where" <+> pretty e <+> text "with" <+> (text . show $ i))+ pretty (ProviderError msg) = text msg pretty _ = text "Error" data TC a = OK a@@ -236,8 +244,8 @@ -} -lookupCtxtName :: Maybe [String] -> Name -> Ctxt a -> [(Name, a)]-lookupCtxtName nspace n ctxt = case Map.lookup (nsroot n) ctxt of+lookupCtxtName :: Name -> Ctxt a -> [(Name, a)]+lookupCtxtName n ctxt = case Map.lookup (nsroot n) ctxt of Just xs -> filterNS (Map.toList xs) Nothing -> [] where@@ -250,12 +258,12 @@ nsmatch (NS _ _) _ = False nsmatch looking found = True -lookupCtxt :: Maybe [String] -> Name -> Ctxt a -> [a]-lookupCtxt ns n ctxt = map snd (lookupCtxtName ns n ctxt)+lookupCtxt :: Name -> Ctxt a -> [a]+lookupCtxt n ctxt = map snd (lookupCtxtName n ctxt) updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a updateDef n f ctxt - = let ds = lookupCtxtName Nothing n ctxt in+ = let ds = lookupCtxtName n ctxt in foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds toAlist :: Ctxt a -> [(Name, a)]@@ -422,7 +430,10 @@ type UCs = (Int, [UConstraint]) -data NameType = Bound | Ref | DCon Int Int | TCon Int Int+data NameType = Bound+ | Ref+ | DCon Int Int -- ^ Data constructor; Ints are tag and arity+ | TCon Int Int -- ^ Type constructor; Ints are tag and arity deriving (Show, Ord) {-! deriving instance Binary NameType
src/Core/Typecheck.hs view
@@ -60,7 +60,7 @@ check' holes ctxt env top = chk env top where chk env (Var n) | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty)- | (P nt n' ty : _) <- lookupP Nothing n ctxt = return (P nt n' ty, ty)+ | (P nt n' ty : _) <- lookupP n ctxt = return (P nt n' ty, ty) | otherwise = do lift $ tfail $ NoSuchVariable n chk env (RApp f a) = do (fv, fty) <- chk env f@@ -81,7 +81,7 @@ let apty = simplify initContext False env (Bind x (Let aty av) t) return (App fv av, apty)- t -> fail "Can't apply a non-function type"+ t -> lift $ tfail $ NonFunctionType fv fty -- "Can't apply a non-function type" -- This rather unpleasant hack is needed because during incomplete -- proofs, variables are locally bound with an explicit name. If we just -- make sure bound names in function types are locally unique, machine@@ -227,7 +227,7 @@ checkProgram ctxt ((n, RConst t) : xs) = do (t', tt') <- trace (show n) $ check ctxt [] t isType ctxt [] tt'- checkProgram (addTyDecl n t' ctxt) xs+ checkProgram (addTyDecl n Ref t' ctxt) xs checkProgram ctxt ((n, RFunction (RawFun ty val)) : xs) = do (ty', tyt') <- trace (show n) $ check ctxt [] ty (val', valt') <- check ctxt [] val
src/Core/Unify.hs view
@@ -29,7 +29,7 @@ unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> TC ([(Name, TT Name)], Fails)-unify ctxt env topx topy injtc holes =+unify ctxt env topx topy dont holes = -- trace ("Unifying " ++ show (topx, topy)) $ -- don't bother if topx and topy are different at the head case runStateT (un False [] topx topy) (UI 0 []) of@@ -54,8 +54,9 @@ injective (P (DCon _ _) _ _) = True injective (P (TCon _ _) _ _) = True- injective (P _ n _) = n `elem` injtc- injective (App f a) = injective f+ injective (App f (P _ _ _)) = injective f + injective (App f (Constant _)) = injective f + injective (App f a) = injective f -- && injective a injective _ = False notP (P _ _ _) = False@@ -94,12 +95,16 @@ = unifyFail topx topy un' fn names topx@(P (TCon _ _) x _) topy@(P (DCon _ _) y _) = unifyFail topx topy+ un' fn names topx@(Constant _) topy@(P (TCon _ _) y _)+ = unifyFail topx topy+ un' fn names topx@(P (TCon _ _) x _) topy@(Constant _)+ = unifyFail topx topy un' fn bnames tx@(P _ x _) ty@(P _ y _) | (x,y) `elem` bnames || x == y = do sc 1; return [] | injective tx && not (holeIn env y || y `elem` holes)- = unifyFail tx ty+ = unifyTmpFail tx ty | injective ty && not (holeIn env x || x `elem` holes)- = unifyFail tx ty+ = unifyTmpFail tx ty un' fn bnames xtm@(P _ x _) tm | holeIn env x || x `elem` holes = do UI s f <- get@@ -128,10 +133,9 @@ | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] un' fn bnames appx@(App fx ax) appy@(App fy ay)- | injective fx && metavarApp appy - || injective fy && metavarApp appx - || injective fx && injective fy - || fx == fy+ | (injective fx && sameArgStruct appx appy && metavarApp appy)+ || (injective fy && sameArgStruct appx appy && metavarApp appx)+ || (injective fx && injective fy) = do let (headx, _) = unApply fx let (heady, _) = unApply fy -- fail quickly if the heads are disjoint@@ -153,17 +157,21 @@ hf <- un' False bnames fx' fy' sc 1 combine bnames hf ha)- | otherwise - = do let (headx, argsx) = unApply appx+ | otherwise = + do let (headx, argsx) = unApply appx let (heady, argsy) = unApply appy+ -- traceWhen (headx == heady) (show (appx, appy)) $ if (length argsx == length argsy && - ((headx == heady) || (argsx == argsy) ||- (notFn headx && notFn heady))) then+ ((headx == heady && inenv headx) || (argsx == argsy) ||+ (and (zipWith sameStruct (headx:argsx) (heady:argsy)))))+ then+-- (notFn headx && notFn heady))) then do uf <- un' True bnames headx heady unArgs uf argsx argsy- else unifyTmpFail appx appy+ else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $ + unifyTmpFail appx appy where hnormalise [] _ _ t = t- hnormalise ns ctxt env t = hnf ctxt env t+ hnormalise ns ctxt env t = normalise ctxt env t checkHeads (P (DCon _ _) x _) (P (DCon _ _) y _) | x /= y = unifyFail appx appy checkHeads (P (TCon _ _) x _) (P (TCon _ _) y _)@@ -183,10 +191,39 @@ unArgs vs xs ys metavarApp tm = let (f, args) = unApply tm in- all (\x -> metavar x || notFn x) (f : args)+ all (\x -> metavar x || inenv x) (f : args)+ metavarArgs tm = let (f, args) = unApply tm in+ all (\x -> metavar x || inenv x) args+ metavarApp' tm = let (f, args) = unApply tm in+ all (\x -> pat x || metavar x) (f : args)++ sameArgStruct appx appy = let (_, ax) = unApply appx+ (_, ay) = unApply appy in+ and (zipWith sameStruct ax ay)++ sameStruct fapp@(App f x) gapp@(App g y) + = let (f',a') = unApply fapp+ (g',b') = unApply gapp in+ (f' == g' && length a' == length b' &&+ (injective f' || injective g'))+ || (sameStruct f g && sameStruct x y)+ sameStruct (P _ x _) (P _ y _) = True+ sameStruct (V i) (V j) = i == j+ sameStruct (Constant x) (Constant y) = True+ sameStruct (P _ _ _) (Constant y) = True+ sameStruct (Constant x) (P _ _ _) = True+ sameStruct (Bind n t sc) (P _ _ _) = True+ sameStruct (P _ _ _) (Bind n t sc) = True+ sameStruct (Bind n t sc) (Bind n' t' sc') = sameStruct sc sc'+ sameStruct _ _ = False+ metavar t = case t of- P _ x _ -> x `elem` holes || holeIn env x+ P _ x _ -> (x `elem` holes || holeIn env x) &&+ not (x `elem` dont) _ -> False+ pat t = case t of+ P _ x _ -> x `elem` holes || patIn env x+ _ -> False inenv t = case t of P _ x _ -> x `elem` (map fst env) _ -> False@@ -197,6 +234,10 @@ | n == n' = un' False bnames x y un' fn bnames (Bind n (Lam t) (App x (P Bound n' _))) y | n == n' = un' False bnames x y+ un' fn bnames x (Bind n (Lam t) (App y (V 0)))+ = un' False bnames x y+ un' fn bnames (Bind n (Lam t) (App x (V 0))) y+ = un' False bnames x y -- un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy) -- = un' False ((x,y):bnames) sx sy -- un' fn bnames (Bind x (PVTy _) sx) (Bind y (PVTy _) sy) @@ -285,8 +326,14 @@ recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) | x == y = True | otherwise = False+ recoverable (Constant _) (P (DCon _ _) y _) = False+ recoverable (P (DCon _ _) x _) (Constant _) = False+ recoverable (Constant _) (P (TCon _ _) y _) = False+ recoverable (P (TCon _ _) x _) (Constant _) = False recoverable (P (DCon _ _) x _) (P (TCon _ _) y _) = False recoverable (P (TCon _ _) x _) (P (DCon _ _) y _) = False+ recoverable p@(Constant _) (App f a) = recoverable p f+ recoverable (App f a) p@(Constant _) = recoverable f p recoverable p@(P _ n _) (App f a) = recoverable p f -- recoverable (App f a) p@(P _ _ _) = recoverable f p recoverable (App f a) (App f' a')@@ -298,5 +345,12 @@ holeIn :: Env -> Name -> Bool holeIn env n = case lookup n env of Just (Hole _) -> True+ Just (Guess _ _) -> True+ _ -> False++patIn :: Env -> Name -> Bool+patIn env n = case lookup n env of+ Just (PVar _) -> True+ Just (PVTy _) -> True _ -> False
src/IRTS/CodegenC.hs view
@@ -10,6 +10,7 @@ import Util.System import Data.Char+import Data.List (intercalate) import System.Process import System.Exit import System.IO@@ -47,7 +48,7 @@ incFlags <- getIncFlags let gcc = comp ++ " " ++ gccDbg dbg ++- " -I. " ++ objs ++ " -x c " ++ + " -I. " ++ objs ++ " -x c " ++ (if (exec == Executable) then "" else " -c ") ++ " " ++ tmpn ++ " " ++ libFlags ++@@ -105,6 +106,10 @@ mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")" mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")" mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")"+ mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")"+ mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"+ mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"+ mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ ")" mkConst _ = "MKINT(42424242)" bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n" bcc i (MKCON l tag args)@@ -222,7 +227,10 @@ bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);" -- bcc i _ = indent i ++ "// not done yet\n" -c_irts FInt l x = l ++ "MKINT((i_int)(" ++ x ++ "))"+++c_irts (FInt ITNative) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"+c_irts (FInt ty) l x = l ++ "idris_b" ++ show (intTyWidth ty) ++ "const(vm, " ++ x ++ ")" c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))" c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")" c_irts FUnit l x = x@@ -230,7 +238,8 @@ c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")" c_irts FAny l x = l ++ x -irts_c FInt x = "GETINT(" ++ x ++ ")"+irts_c (FInt ITNative) x = "GETINT(" ++ x ++ ")"+irts_c (FInt ty) x = "(" ++ x ++ "->info.bits" ++ show (intTyWidth ty) ++ ")" irts_c FChar x = "GETINT(" ++ x ++ ")" irts_c FString x = "GETSTR(" ++ x ++ ")" irts_c FUnit x = x@@ -238,23 +247,34 @@ irts_c FDouble x = "GETFLOAT(" ++ x ++ ")" irts_c FAny x = x -doOp v LPlus [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LMinus [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LTimes [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LDiv [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LMod [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LAnd [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LOr [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LXOr [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LSHL [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LSHR [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LCompl [x] = v ++ "INTOP(~," ++ creg x ++ ")"-doOp v LEq [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LLt [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LLe [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LGt [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LGe [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"+bitOp v op ty args = v ++ "idris_b" ++ show (intTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")" +bitCoerce v op input output arg+ = v ++ "idris_b" ++ show (intTyWidth input) ++ op ++ show (intTyWidth output) ++ "(vm, " ++ creg arg ++ ")"++signedTy :: IntTy -> String+signedTy t = "int" ++ show (intTyWidth t) ++ "_t"++doOp v (LPlus ITNative) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LMinus ITNative) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LTimes ITNative) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LSDiv ITNative) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LSRem ITNative) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"+doOp v (LEq ITNative) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LLt ITNative) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LLe ITNative) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LGt ITNative) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LGe ITNative) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"+ doOp v LFPlus [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFMinus [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFTimes [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"@@ -265,31 +285,30 @@ doOp v LFGt [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFGe [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v LBPlus [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LBMinus [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LBDec [l] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", MKINT(1))"-doOp v LBTimes [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LBDiv [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LBMod [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LBEq [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LBLt [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LBLe [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LBGt [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LBGe [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LPlus ITBig) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LMinus ITBig) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LTimes ITBig) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LSDiv ITBig) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LSRem ITBig) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LEq ITBig) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LLt ITBig) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LLe ITBig) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LGt ITBig) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v (LGe ITBig) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")" -doOp v LIntFloat [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"-doOp v LFloatInt [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"-doOp v LIntStr [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"-doOp v LStrInt [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"-doOp v LIntBig [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"-doOp v LBigInt [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"-doOp v LStrBig [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"-doOp v LBigStr [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"+doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"+doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"+doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"+doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"+doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"+doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"+doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"+doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")" doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")" doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")" @@ -297,143 +316,43 @@ doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))" doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)" -doOp v LIntB8 [x] = v ++ "idris_b8(vm, " ++ creg x ++ ")"-doOp v LIntB16 [x] = v ++ "idris_b16(vm, " ++ creg x ++ ")"-doOp v LIntB32 [x] = v ++ "idris_b32(vm, " ++ creg x ++ ")"-doOp v LIntB64 [x] = v ++ "idris_b64(vm, " ++ creg x ++ ")"--doOp v LB32Int [x] = v ++ "idris_castB32Int(vm, " ++ creg x ++ ")"--doOp v LB8Lt [x, y] = v ++ "idris_b8Lt(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8Lte [x, y] = v ++ "idris_b8Lte(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8Eq [x, y] = v ++ "idris_b8Eq(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8Gte [x, y] = v ++ "idris_b8Gte(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8Gt [x, y] = v ++ "idris_b8Gt(vm, " ++ creg x ++ "," ++ creg y ++ ")"--doOp v LB8Shl [x, y] = v ++ "idris_b8Shl(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8LShr [x, y] = v ++ "idris_b8Shr(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8AShr [x, y] = v ++ "idris_b8AShr(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8And [x, y] = v ++ "idris_b8And(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8Or [x, y] = v ++ "idris_b8Or(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8Xor [x, y] = v ++ "idris_b8Xor(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8Compl [x] = v ++ "idris_b8Compl(vm, " ++ creg x ++ ")"--doOp v LB8Plus [x, y] = v ++ "idris_b8Plus(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8Minus [x, y] = v ++ "idris_b8Minus(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8Times [x, y] = v ++ "idris_b8Times(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8UDiv [x, y] = v ++ "idris_b8UDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8SDiv [x, y] = v ++ "idris_b8SDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8URem [x, y] = v ++ "idris_b8URem(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB8SRem [x, y] = v ++ "idris_b8SRem(vm, " ++ creg x ++ "," ++ creg y ++ ")"--doOp v LB8Z16 [x] = v ++ "idris_b8Z16(vm, " ++ creg x ++ ")"-doOp v LB8Z32 [x] = v ++ "idris_b8Z32(vm, " ++ creg x ++ ")"-doOp v LB8Z64 [x] = v ++ "idris_b8Z64(vm, " ++ creg x ++ ")"-doOp v LB8S16 [x] = v ++ "idris_b8S16(vm, " ++ creg x ++ ")"-doOp v LB8S32 [x] = v ++ "idris_b8S32(vm, " ++ creg x ++ ")"-doOp v LB8S64 [x] = v ++ "idris_b8S64(vm, " ++ creg x ++ ")"--doOp v LB16Lt [x, y] = v ++ "idris_b16Lt(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16Lte [x, y] = v ++ "idris_b16Lte(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16Eq [x, y] = v ++ "idris_b16Eq(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16Gte [x, y] = v ++ "idris_b16Gte(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16Gt [x, y] = v ++ "idris_b16Gt(vm, " ++ creg x ++ "," ++ creg y ++ ")"--doOp v LB16Shl [x, y] = v ++ "idris_b16Shl(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16LShr [x, y] = v ++ "idris_b16Shr(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16AShr [x, y] = v ++ "idris_b16AShr(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16And [x, y] = v ++ "idris_b16And(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16Or [x, y] = v ++ "idris_b16Or(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16Xor [x, y] = v ++ "idris_b16Xor(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16Compl [x] = v ++ "idris_b16Compl(vm, " ++ creg x ++ ")"--doOp v LB16Plus [x, y] =- v ++ "idris_b16Plus(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16Minus [x, y] =- v ++ "idris_b16Minus(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16Times [x, y] =- v ++ "idris_b16Times(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16UDiv [x, y] =- v ++ "idris_b16UDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16SDiv [x, y] =- v ++ "idris_b16SDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16URem [x, y] =- v ++ "idris_b16URem(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB16SRem [x, y] =- v ++ "idris_b16SRem(vm, " ++ creg x ++ "," ++ creg y ++ ")"--doOp v LB16Z32 [x] = v ++ "idris_b16Z32(vm, " ++ creg x ++ ")"-doOp v LB16Z64 [x] = v ++ "idris_b16Z64(vm, " ++ creg x ++ ")"-doOp v LB16S32 [x] = v ++ "idris_b16S32(vm, " ++ creg x ++ ")"-doOp v LB16S64 [x] = v ++ "idris_b16S64(vm, " ++ creg x ++ ")"-doOp v LB16T8 [x] = v ++ "idris_b16T8(vm, " ++ creg x ++ ")"--doOp v LB32Lt [x, y] = v ++ "idris_b32Lt(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32Lte [x, y] = v ++ "idris_b32Lte(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32Eq [x, y] = v ++ "idris_b32Eq(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32Gte [x, y] = v ++ "idris_b32Gte(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32Gt [x, y] = v ++ "idris_b32Gt(vm, " ++ creg x ++ "," ++ creg y ++ ")"--doOp v LB32Shl [x, y] = v ++ "idris_b32Shl(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32LShr [x, y] = v ++ "idris_b32Shr(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32AShr [x, y] = v ++ "idris_b32AShr(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32And [x, y] = v ++ "idris_b32And(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32Or [x, y] = v ++ "idris_b32Or(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32Xor [x, y] = v ++ "idris_b32Xor(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32Compl [x] = v ++ "idris_b32Compl(vm, " ++ creg x ++ ")"--doOp v LB32Plus [x, y] =- v ++ "idris_b32Plus(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32Minus [x, y] =- v ++ "idris_b32Minus(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32Times [x, y] =- v ++ "idris_b32Times(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32UDiv [x, y] =- v ++ "idris_b32UDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32SDiv [x, y] =- v ++ "idris_b32SDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32URem [x, y] =- v ++ "idris_b32URem(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB32SRem [x, y] =- v ++ "idris_b32SRem(vm, " ++ creg x ++ "," ++ creg y ++ ")"--doOp v LB32Z64 [x] = v ++ "idris_b32Z64(vm, " ++ creg x ++ ")"-doOp v LB32S64 [x] = v ++ "idris_b32S64(vm, " ++ creg x ++ ")"-doOp v LB32T8 [x] = v ++ "idris_b32T8(vm, " ++ creg x ++ ")"-doOp v LB32T16 [x] = v ++ "idris_b32T16(vm, " ++ creg x ++ ")"--doOp v LB64Lt [x, y] = v ++ "idris_b64Lt(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64Lte [x, y] = v ++ "idris_b64Lte(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64Eq [x, y] = v ++ "idris_b64Eq(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64Gte [x, y] = v ++ "idris_b64Gte(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64Gt [x, y] = v ++ "idris_b64Gt(vm, " ++ creg x ++ "," ++ creg y ++ ")"+doOp v (LLt ty) [x, y] = bitOp v "Lt" ty [x, y]+doOp v (LLe ty) [x, y] = bitOp v "Lte" ty [x, y]+doOp v (LEq ty) [x, y] = bitOp v "Eq" ty [x, y]+doOp v (LGe ty) [x, y] = bitOp v "Gte" ty [x, y]+doOp v (LGt ty) [x, y] = bitOp v "Gt" ty [x, y] -doOp v LB64Shl [x, y] = v ++ "idris_b64Shl(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64LShr [x, y] = v ++ "idris_b64Shr(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64AShr [x, y] = v ++ "idris_b64AShr(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64And [x, y] = v ++ "idris_b64And(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64Or [x, y] = v ++ "idris_b64Or(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64Xor [x, y] = v ++ "idris_b64Xor(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64Compl [x] = v ++ "idris_b64Compl(vm, " ++ creg x ++ ")"+doOp v (LSHL ty) [x, y] = bitOp v "Shl" ty [x, y]+doOp v (LLSHR ty) [x, y] = bitOp v "Shr" ty [x, y]+doOp v (LASHR ty) [x, y] = bitOp v "AShr" ty [x, y]+doOp v (LAnd ty) [x, y] = bitOp v "And" ty [x, y]+doOp v (LOr ty) [x, y] = bitOp v "Or" ty [x, y]+doOp v (LXOr ty) [x, y] = bitOp v "Xor" ty [x, y]+doOp v (LCompl ty) [x] = bitOp v "Compl" ty [x] -doOp v LB64Plus [x, y] =- v ++ "idris_b64Plus(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64Minus [x, y] =- v ++ "idris_b64Minus(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64Times [x, y] =- v ++ "idris_b64Times(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64UDiv [x, y] =- v ++ "idris_b64UDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64SDiv [x, y] =- v ++ "idris_b64SDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64URem [x, y] =- v ++ "idris_b64URem(vm, " ++ creg x ++ "," ++ creg y ++ ")"-doOp v LB64SRem [x, y] =- v ++ "idris_b64SRem(vm, " ++ creg x ++ "," ++ creg y ++ ")"+doOp v (LPlus ty) [x, y] = bitOp v "Plus" ty [x, y]+doOp v (LMinus ty) [x, y] = bitOp v "Minus" ty [x, y]+doOp v (LTimes ty) [x, y] = bitOp v "Times" ty [x, y]+doOp v (LUDiv ty) [x, y] = bitOp v "UDiv" ty [x, y]+doOp v (LSDiv ty) [x, y] = bitOp v "SDiv" ty [x, y]+doOp v (LURem ty) [x, y] = bitOp v "URem" ty [x, y]+doOp v (LSRem ty) [x, y] = bitOp v "SRem" ty [x, y] -doOp v LB64T8 [x] = v ++ "idris_b64T8(vm, " ++ creg x ++ ")"-doOp v LB64T16 [x] = v ++ "idris_b64T16(vm, " ++ creg x ++ ")"-doOp v LB64T32 [x] = v ++ "idris_b64T32(vm, " ++ creg x ++ ")"+doOp v (LSExt from ITBig) [x] = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"+doOp v (LSExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"+doOp v (LSExt from ITNative) [x] = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ "))"+doOp v (LSExt from to) [x]+ | intTyWidth from < intTyWidth to = bitCoerce v "S" from to x+doOp v (LZExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")"+doOp v (LZExt from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"+doOp v (LZExt from ITBig) [x] = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"+doOp v (LZExt from to) [x]+ | intTyWidth from < intTyWidth to = bitCoerce v "Z" from to x+doOp v (LTrunc ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"+doOp v (LTrunc from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"+doOp v (LTrunc ITBig to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, mpz_get_ui(GETMPZ(" ++ creg x ++ "))"+doOp v (LTrunc from to) [x]+ | intTyWidth from > intTyWidth to = bitCoerce v "T" from to x doOp v LFExp [x] = v ++ "MKFLOAT(exp(GETFLOAT(" ++ creg x ++ ")))" doOp v LFLog [x] = v ++ "MKFLOAT(log(GETFLOAT(" ++ creg x ++ ")))"@@ -460,7 +379,7 @@ doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"-doOp v LChInt args = v ++ creg (last args)-doOp v LIntCh args = v ++ creg (last args)+doOp v (LChInt ITNative) args = v ++ creg (last args)+doOp v (LIntCh ITNative) args = v ++ creg (last args) doOp v LNoOp args = v ++ creg (last args) doOp _ op _ = "FAIL /* " ++ show op ++ " */"
src/IRTS/CodegenJava.hs view
@@ -1,23 +1,1588 @@ module IRTS.CodegenJava (codegenJava) where -import IRTS.BCImp-import IRTS.Lang-import IRTS.Simplified-import Core.TT-import Paths_idris-import Util.System-import IRTS.CodegenCommon--import Data.Char-import System.Process-import System.Exit-import System.IO-import System.Directory-import Control.Monad--codegenJava :: [(Name, SDecl)] ->- String -> -- output file name- OutputType ->- IO ()-codegenJava defs out exec = putStrLn "Not implemented yet"-+import Core.TT+import IRTS.BCImp+import IRTS.CodegenCommon+import IRTS.Lang+import IRTS.Simplified+import Paths_idris+import Util.System++import Control.Applicative+import Control.Arrow+import Control.Monad+import qualified Control.Monad.Trans as T+import Control.Monad.Trans.State+import Data.Char+import Data.Maybe (fromJust)+import Data.List (isPrefixOf, isSuffixOf, intercalate, foldl')+import Data.Int+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+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++data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Integer)] }++type CodeGeneration = StateT (CodeGenerationEnv) (Either String)++codegenJava :: [(Name, SExp)] -> -- initialization of globals+ [(Name, SDecl)] ->+ FilePath -> -- output file name+ [String] -> -- headers+ [String] -> -- libs+ OutputType ->+ IO ()+codegenJava globalInit defs out hdrs libs exec = do+ withTempdir (takeBaseName out) $ \ tmpDir -> do+ let srcdir = tmpDir </> "src" </> "main" </> "java"+ createDirectoryIfMissing True srcdir+ let (Ident clsName) = + either error id (evalStateT (mkClassName out) (mkCodeGenEnv globalInit))+ let outjava = srcdir </> clsName <.> "java"+ let jout = either error+ (flatIndent . prettyPrint)+ (evalStateT (mkCompilationUnit globalInit defs hdrs out) (mkCodeGenEnv globalInit))+ writeFile outjava jout+ if (exec == Raw)+ then copyFile outjava (takeDirectory out </> clsName <.> "java")+ else do+ execPom <- getExecutablePom+ execPomTemplate <- TIO.readFile execPom+ let execPom = T.replace (T.pack "$MAIN-CLASS$")+ (T.pack clsName)+ (T.replace (T.pack "$ARTIFACT-NAME$") + (T.pack $ takeBaseName out) + (T.replace (T.pack "$DEPENDENCIES$")+ (mkPomDependencies libs)+ execPomTemplate+ )+ )+ TIO.writeFile (tmpDir </> "pom.xml") execPom+ mvnCmd <- getMvn+ let args = ["-f", (tmpDir </> "pom.xml")]+ (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["compile"]) ""+ when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout)+ if (exec == Object)+ then do+ classFiles <- + map (\ clsFile -> tmpDir </> "target" </> "classes" </> clsFile)+ . filter ((".class" ==) . takeExtension) + <$> getDirectoryContents (tmpDir </> "target" </> "classes")+ mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile)) + classFiles+ else do+ (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) ""+ when (exit /= ExitSuccess) (error ("FAILURE: " ++ mvnCmd ++ " package\n" ++ err ++ mvout))+ copyFile (tmpDir </> "target" </> (takeBaseName out) <.> "jar") out+ 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)+ readProcess mvnCmd (args ++ ["clean"]) ""+ removeFile (tmpDir </> "pom.xml")++jarHeader :: String+jarHeader = + "#!/bin/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 \"$@\""+ ++ "exit 1\n"++mkPomDependencies :: [String] -> T.Text+mkPomDependencies deps =+ T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps+ where+ mkDependency s = + case T.splitOn (T.pack ":") s of+ [g, a, v] ->+ [ T.pack $ "<dependency>\n"+ , T.append (T.pack " ") $ mkGroupId g+ , T.append (T.pack " ") $ mkArtifactId a+ , T.append (T.pack " ") $ mkVersion v+ , T.pack $ "</dependency>\n"+ ]+ _ -> []+ mkGroupId g = T.append (T.pack $ "<groupId>") (T.append g $ T.pack "</groupId>\n")+ mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")+ mkVersion v = T.append (T.pack $ "<version>") (T.append v $ T.pack "</version>\n")++mkCodeGenEnv :: [(Name, SExp)] -> CodeGenerationEnv+mkCodeGenEnv globalInit = + CodeGenerationEnv $ zipWith (\ (name, _) pos -> (name, pos)) globalInit [0..]++mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit+mkCompilationUnit globalInit defs hdrs out =+ CompilationUnit Nothing ( [ ImportDecl False idrisRts True+ , ImportDecl True idrisForeign True+ , ImportDecl False bigInteger False+ , ImportDecl False stringBuffer False+ , ImportDecl False runtimeException False+ , ImportDecl False scanner False+ , ImportDecl False arrays False+ ] ++ otherHdrs+ )+ <$> mkTypeDecl globalInit defs out+ where+ idrisRts = J.Name $ map Ident ["org", "idris", "rts"]+ idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"]+ bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]+ stringBuffer = J.Name $ map Ident ["java", "lang", "StringBuffer"]+ runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]+ scanner = J.Name $ map Ident ["java", "util", "Scanner"]+ arrays = J.Name $ map Ident ["java", "util", "Arrays"]+ otherHdrs = map ( (\ name -> ImportDecl False name False)+ . J.Name + . map (Ident . T.unpack) + . T.splitOn (T.pack ".") + . T.pack) + $ filter (not . isSuffixOf ".h") hdrs++flatIndent :: String -> String+flatIndent (' ' : ' ' : xs) = flatIndent xs+flatIndent (x:xs) = x:flatIndent xs+flatIndent [] = []++prefixCallNamespaces :: Ident -> SExp -> SExp+prefixCallNamespaces (Ident name) (SApp tail (NS n ns) args) = SApp tail (NS n (name:ns)) args+prefixCallNamespaces name (SLet var e1 e2) = SLet var (prefixCallNamespaces name e1) (prefixCallNamespaces name e2)+prefixCallNamespaces name (SUpdate var e) = SUpdate var (prefixCallNamespaces name e)+prefixCallNamespaces name (SCase var alts) = SCase var (map (prefixCallNamespacesCase name) alts)+prefixCallNamespaces name (SChkCase var alts) = SChkCase var (map (prefixCallNamespacesCase name) alts)+prefixCallNamespaces _ exp = exp++prefixCallNamespacesCase :: Ident -> SAlt -> SAlt+prefixCallNamespacesCase name (SConCase x y n ns e) = SConCase x y n ns (prefixCallNamespaces name e)+prefixCallNamespacesCase name (SConstCase c e) = SConstCase c (prefixCallNamespaces name e)+prefixCallNamespacesCase name (SDefaultCase e) = SDefaultCase (prefixCallNamespaces name e)++prefixCallNamespacesDecl :: Ident -> SDecl -> SDecl+prefixCallNamespacesDecl name (SFun fname args i e) = SFun fname args i (prefixCallNamespaces name e)++mkTypeDecl :: [(Name, SExp)] -> [(Name, SDecl)] -> FilePath -> CodeGeneration [TypeDecl]+mkTypeDecl globalInit defs out =+ (\ name body -> [ClassTypeDecl $ ClassDecl [ Public+ , Annotation $ SingleElementAnnotation + (J.Name [Ident "SuppressWarnings"])+ (EVVal . InitExp . Lit $ String "unchecked")+ ] + name + [] + Nothing + [] + body])+ <$> mkClassName out+ <*> ( mkClassName out + >>= (\ ident -> mkClassBody globalInit (map (second (prefixCallNamespacesDecl ident)) defs))+ )++mkClassName :: FilePath -> CodeGeneration Ident+mkClassName path =+ T.lift $ left (\ err -> "Parser error in \"" ++ path ++ "\": " ++ (show err))+ (parser ident . takeBaseName $ takeFileName path)++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 = + (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final] + objectArrayType + [VarDecl (VarId $ Ident "globalContext") + (Just . InitArray $ ArrayInit exps) + ]+ ]+ )+ <$> mapM (\ (_, exp) -> InitExp <$> mkExp exp) initExps++ ++addMainMethod :: [Decl] -> [Decl]+addMainMethod decls+ | findMain decls = mkMainMethod : decls+ | otherwise = decls+ where+ findMain ((MemberDecl (MemberClassDecl (ClassDecl _ (Ident "Main") _ _ _ (ClassBody body)))):_) =+ findMainMethod body+ findMain (_:decls) = findMain decls+ findMain [] = False++ findMainMethod ((MemberDecl (MethodDecl _ _ _ (Ident "main") [] _ _)):_) = True+ findMainMethod (_:decls) = findMainMethod decls+ findMainMethod [] = False++mkMainMethod :: Decl+mkMainMethod = + MemberDecl $ MethodDecl [Public, Static] + [] + Nothing + (Ident "main") + [FormalParam [] stringArrayType False (VarId $ Ident "args")]+ [] + (MethodBody . Just $ Block [ BlockStmt . ExpStmt . MethodInv $+ MethodCall (J.Name [Ident "idris_initArgs"])+ [ MethodInv $ TypeMethodCall+ (J.Name [Ident "Thread"])+ []+ (Ident "currentThread")+ []+ , ExpName $ J.Name [Ident "args"]+ ] + , BlockStmt . ExpStmt . MethodInv $+ MethodCall (J.Name [Ident "runMain_0"])+ []+ ]+ )++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']+++mkIdentifier :: Name -> CodeGeneration Ident+mkIdentifier (NS name _) = mkIdentifier name+mkIdentifier (MN i name) = (\ (Ident x) -> Ident $ x ++ ('_' : show i))+ <$> mkIdentifier (UN name)+mkIdentifier (UN name) =+ T.lift $ left (\ err -> "Parser error in \"" ++ name ++ "\": " ++ (show err))+ ( parser ident+ . cleanReserved+ . cleanNonLetter+ . cleanStart+ $ cleanWs False name)+ where+ cleanStart (x:xs)+ | isNumber x = '_' : (x:xs)+ | otherwise = (x:xs)+ cleanStart [] = []+ 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 == '_' = "__" ++ cleanNonLetter xs+ | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ 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 _ [] = []+++ cleanReserved "param" = "_param"+ cleanReserved "globalContext" = "_globalContext"+ cleanReserved "context" = "_context"+ cleanReserved "newcontext" = "_newcontext"++ cleanReserved "void" = "_void"+ cleanReserved "null" = "_null"+ cleanReserved "int" = "_int"+ cleanReserved "long" = "_long"+ cleanReserved "char" = "_char"+ cleanReserved "byte" = "_byte"+ cleanReserved "double" = "_double"+ cleanReserved "float" = "_float"+ cleanReserved "boolean" = "_boolean"+ cleanReserved "Object" = "_Object"+ cleanReserved "String" = "_String"+ cleanReserved "StringBuilder" = "_StringBuilder"+ cleanReserved "StringBuffer" = "_StringBuffer"+ cleanReserved "Scanner" = "_Scanner"+ cleanReserved "Integer" = "_Integer"+ cleanReserved "Double" = "_Double"+ cleanReserved "Byte" = "_Byte"+ cleanReserved "Character" = "_Character"+ cleanReserved "BigInteger" = "_BigInteger"+ cleanReserved "Boolean" = "_Boolean"+ cleanReserved "Closure" = "_Closure"+ cleanReserved "IdrisObject" = "_IdrisObject"+ cleanReserved "TailCallClosure" = "_TailCallClosure"+ cleanReserved "System" = "_System"+ cleanReserved "Math" = "_Math"+ cleanReserved "Arrays" = "_Arrays"+ cleanReserved "RuntimeException" = "_RuntimeException"+ cleanReserved "Comparable" = "_Comparable"++ cleanReserved "class" = "_class"+ cleanReserved "enum" = "_enum"+ cleanReserved "interface" = "_interface"+ cleanReserved "extends" = "_extends"+ cleanReserved "implements" = "_implements"+ cleanReserved "public" = "_public"+ cleanReserved "private" = "_private"+ cleanReserved "protected" = "_protected"+ cleanReserved "static" = "_static"+ cleanReserved "final" = "_final"+ cleanReserved "abstract" = "_abstract"+ cleanReserved "strict" = "_strict"+ cleanReserved "volatile" = "_volatile"+ cleanReserved "transient" = "_transient"+ cleanReserved "native" = "_native"+ cleanReserved "const" = "_const"++ cleanReserved "import" = "_import"+ cleanReserved "package" = "_package"++ cleanReserved "throw" = "_throw"+ cleanReserved "throws" = "_throws"+ cleanReserved "try" = "_try"+ cleanReserved "catch" = "_catch"++ cleanReserved "synchronized" = "_synchronized"++ cleanReserved "if" = "_if"+ cleanReserved "else" = "_else"+ cleanReserved "switch" = "_switch"+ cleanReserved "case" = "_case"+ cleanReserved "default" = "_default"++ cleanReserved "while" = "_while"+ cleanReserved "for" = "_for"+ cleanReserved "do" = "_do"+ cleanReserved "break" = "_break"+ cleanReserved "continue" = "_continue"+ cleanReserved "goto" = "_goto"++ cleanReserved "this" = "_this"+ cleanReserved "super" = "_super"+ cleanReserved "new" = "_new"+ cleanReserved "return" = "_return"++ cleanReserved "idris_initArgs" = "_idris_initArgs"+ cleanReserved "idris_numArgs" = "_idris_numArgs"+ cleanReserved "idris_getArg" = "_idris_getArg"+ cleanReserved "getenv" = "_getenv"+ cleanReserved "exit" = "_exit"+ cleanReserved "usleep" = "_usleep"+ cleanReserved "idris_sendMessage" = "_idris_sendMessage"+ cleanReserved "idris_checkMessage" = "_idris_checkMessage"+ cleanReserved "idris_recvMessage" = "_idris_recvMessage"+ cleanReserved "putStr" = "_putStr"+ cleanReserved "putchar" = "_putchar"+ cleanReserved "getchar" = "_getchar"+ cleanReserved "fileOpen" = "_fileOpen"+ cleanReserved "fileClose" = "_fileClose"+ cleanReserved "fputStr" = "_fputStr"+ cleanReserved "fileEOF" = "_fileEOF"+ cleanReserved "isNull" = "_isNull"+ cleanReserved "idris_K" = "_idris_K"+ cleanReserved "idris_flipK" = "_idris_flipK"+ cleanReserved "idris_assignStack" = "_idris_assignStack"+ cleanReserved "free" = "_free"+ cleanReserved "malloc" = "_malloc"+ cleanReserved "idris_memset" = "_idris_memset"+ cleanReserved "idris_peek" = "_idris_peek"+ cleanReserved "idris_poke" = "_idris_poke"+ cleanReserved "idris_memmove" = "_idris_memmove"++ cleanReserved x = x++mkName :: Name -> CodeGeneration J.Name+mkName (NS name nss) = (\ n ns -> J.Name (n:ns))+ <$> mkIdentifier name+ <*> mapM (mkIdentifier . UN) nss+mkName n = J.Name . (:[]) <$> mkIdentifier n++voidType :: ClassType+voidType = ClassType [(Ident "Void", [])]++objectType :: ClassType+objectType = ClassType [(Ident "Object", [])]++objectArrayType :: Language.Java.Syntax.Type+objectArrayType = RefType . ArrayType . RefType . ClassRefType $ objectType++idrisClosureType :: ClassType+idrisClosureType = ClassType [(Ident "Closure", [])]++idrisTailCallClosureType :: ClassType+idrisTailCallClosureType = ClassType [(Ident "TailCallClosure", [])]++idrisObjectType :: ClassType+idrisObjectType = ClassType [(Ident "IdrisObject", [])]++contextArray :: LVar -> Exp+contextArray (Loc _) = ExpName $ J.Name [Ident "context"]+contextArray (Glob _) = ExpName $ J.Name [Ident "globalContext"]++charType :: ClassType+charType = ClassType [(Ident "Character", [])]++byteType :: ClassType+byteType = ClassType [(Ident "Byte", [])]++shortType :: ClassType+shortType = ClassType [(Ident "Short", [])]++integerType :: ClassType+integerType = ClassType [(Ident "Integer", [])]++longType :: ClassType+longType = ClassType [(Ident "Long", [])]++nextIntTy :: IntTy -> IntTy+nextIntTy IT8 = IT16+nextIntTy IT16 = IT32+nextIntTy IT32 = IT64+nextIntTy IT64 = IT64+nextIntTy ITNative = IT64++intTyToIdent :: IntTy -> Ident+intTyToIdent IT8 = Ident "Byte"+intTyToIdent IT16 = Ident "Short"+intTyToIdent IT32 = Ident "Integer"+intTyToIdent IT64 = Ident "Long"+intTyToIdent ITNative = Ident "Integer"+intTyToIdent ITBig = Ident "BigInteger"++intTyToClass :: IntTy -> ClassType+intTyToClass ty = ClassType [(intTyToIdent ty, [])]++intTyToMethod :: IntTy -> String+intTyToMethod IT8 = "byteValue"+intTyToMethod IT16 = "shortValue"+intTyToMethod IT32 = "intValue"+intTyToMethod IT64 = "longValue"+intTyToMethod ITNative = "intValue"++intTyToPrimTy :: IntTy -> PrimType+intTyToPrimTy IT8 = ByteT+intTyToPrimTy IT16 = ShortT+intTyToPrimTy IT32 = IntT+intTyToPrimTy IT64 = LongT+intTyToPrimTy ITNative = IntT++bigIntegerType :: ClassType+bigIntegerType = ClassType [(Ident "BigInteger", [])]++doubleType :: ClassType+doubleType = ClassType [(Ident "Double", [])]++stringType :: ClassType+stringType = ClassType [(Ident "String", [])]++stringArrayType :: Language.Java.Syntax.Type+stringArrayType = RefType . ArrayType . RefType . ClassRefType $ stringType++exceptionType :: ClassType+exceptionType = ClassType [(Ident "Throwable", [])]++runtimeExceptionType :: ClassType+runtimeExceptionType = ClassType [(Ident "RuntimeException", [])]++comparableType :: ClassType+comparableType = ClassType [(Ident "Comparable", [])]++mkDecl :: (Name, SDecl) -> CodeGeneration Decl+mkDecl ((NS n (ns:nss)), decl) =+ (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)+ <$> mkIdentifier (UN ns)+ <*> mkClassBody [] [(NS n nss, decl)]+mkDecl (_, SFun name params stackSize body) =+ (\ name params paramNames methodBody ->+ MemberDecl $ MethodDecl [Public, Static]+ []+ (Just . RefType $ ClassRefType objectType)+ name+ params+ []+ (MethodBody . Just $ Block + [ LocalVars [Final]+ objectArrayType+ [ VarDecl (VarDeclArray . VarId $ Ident "context")+ (Just . InitArray . ArrayInit $+ paramNames + ++ replicate stackSize (InitExp . Lit $ Null))+ ]+ , BlockStmt . Return $ Just methodBody+ ]+ )+ )+ <$> mkIdentifier name+ <*> mapM mkFormalParam params+ <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params+ <*> mkExp body+++mkClosure :: [Name] -> Int -> SExp -> CodeGeneration Exp+mkClosure params stackSize body =+ (\ paramArray body -> + InstanceCreation [] + idrisClosureType + [paramArray]+ (Just $ ClassBody [body])+ )+ <$> mkStackInit params stackSize+ <*> mkClosureCall body++mkFormalParam :: Name -> CodeGeneration FormalParam+mkFormalParam name =+ (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))+ <$> mkIdentifier name++mkClosureCall :: SExp -> CodeGeneration Decl+mkClosureCall body =+ (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)+ <$> mkMethodBody body++mkMethodBody :: SExp -> CodeGeneration MethodBody+mkMethodBody exp =+ (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])+ <$> mkExp exp++mkStackInit :: [Name] -> Int -> CodeGeneration Exp+mkStackInit params stackSize =+ (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $+ (map (InitExp . ExpName) localVars)+ ++ (replicate (stackSize) (InitExp $ Lit Null)))+ <$> mapM mkName params++mkK :: Exp -> Exp -> Exp+mkK result drop = + MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ]++mkFlipK :: Exp -> Exp -> Exp+mkFlipK drop result = + MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]++mkLet :: LVar -> SExp -> SExp -> CodeGeneration Exp+mkLet (Loc pos) oldExp newExp =+ (\ oldExp newExp ->+ mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])+ (Lit $ Int (toInteger pos)))+ EqualA+ newExp+ )+ oldExp+ )+ <$> mkExp oldExp+ <*> mkExp newExp+mkLet (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"++reverseNameSpace :: J.Name -> J.Name+reverseNameSpace (J.Name ids) =+ J.Name ((tail ids) ++ [head ids])++mkCase :: Bool -> LVar -> [SAlt] -> CodeGeneration Exp+mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) =+ mkConsCase checked+ var+ parentStackPos + consIndex + params + branchExpression+ (SCase var cases)+mkCase checked var (c@(SConstCase constant branchExpression):cases) =+ (\ constant branchExpression alternative var-> + Cond ( MethodInv $ PrimaryMethodCall (constant)+ []+ (Ident "equals")+ [var]+ )+ branchExpression+ alternative+ )+ <$> mkExp (SConst constant)+ <*> mkExp branchExpression+ <*> mkCase checked var cases+ <*> mkVarAccess Nothing var+mkCase checked var (SDefaultCase exp:cases) = mkExp exp+mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern")++mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> CodeGeneration Exp+mkConsCase checked+ toDeconstruct+ parentStackStart + consIndex + params + branchExpression + alternative =+ (\ caseBinding alternative var varCasted-> + Cond (BinOp (InstanceOf (var) + (ClassRefType idrisObjectType)+ )+ CAnd+ ( BinOp+ ( MethodInv $ PrimaryMethodCall (varCasted)+ []+ (Ident "getConstructorId")+ []+ )+ Equal+ (Lit $ Int (toInteger consIndex))+ )+ )+ (caseBinding)+ alternative+ )+ <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression+ <*> mkExp alternative+ <*> mkVarAccess (Nothing) toDeconstruct+ <*> mkVarAccess (Just idrisObjectType) toDeconstruct+++mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> CodeGeneration Exp+mkCaseBinding True var parentStackStart params branchExpression =+ (\ branchExpression deconstruction -> + mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"])+ ( (ExpName $ J.Name [Ident "context"])+ : (Lit $ Int (toInteger parentStackStart))+ : deconstruction+ ))+ (branchExpression)+ )+ <$> mkExp branchExpression+ <*> mkCaseBindingDeconstruction var params+mkCaseBinding False var parentStackStart params branchExpression =+ (\ bindingMethod deconstruction ->+ MethodInv $ PrimaryMethodCall + ( MethodInv $ PrimaryMethodCall (InstanceCreation []+ (ClassType [(Ident "Object", [])])+ []+ (Just $ ClassBody [MemberDecl $ bindingMethod])+ )+ []+ (Ident "apply")+ ( contextArray (Loc undefined) : deconstruction )+ )+ []+ (Ident "call")+ []+ )+ <$> mkCaseBindingMethod parentStackStart params branchExpression+ <*> mkCaseBindingDeconstruction var params++mkCaseBindingDeconstruction :: LVar -> [Name] -> CodeGeneration [Exp]+mkCaseBindingDeconstruction var members =+ mapM (mkProjection var) ([0..(length members - 1)])++mkCaseBindingMethod :: Int -> [Name] -> SExp -> CodeGeneration MemberDecl+mkCaseBindingMethod parentStackStart params branchExpression =+ (\ formalParams caseBindingStack branchExpression -> + MethodDecl [Final, Public]+ []+ (Just . RefType $ ClassRefType idrisClosureType)+ (Ident "apply")+ (mkContextParam:formalParams)+ []+ (MethodBody . Just . Block $+ caseBindingStack +++ [BlockStmt . Return $ Just branchExpression]))+ <$> mapM mkFormalParam params+ <*> mkBindingStack False parentStackStart params+ <*> mkBindingClosure branchExpression++mkContextParam :: FormalParam+mkContextParam = + FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))++mkBindingClosure :: SExp -> CodeGeneration Exp+mkBindingClosure oldExp =+ (\ oldCall -> + InstanceCreation [] + idrisClosureType+ [ ExpName $ J.Name [Ident "new_context"] ]+ (Just $ ClassBody [oldCall])+ )+ <$> mkClosureCall oldExp+++mkBindingStack :: Bool -> Int -> [Name] -> CodeGeneration [BlockStmt]+mkBindingStack checked parentStackStart params =+ (\ paramNames ->+ ( LocalVars [Final]+ objectArrayType+ [ VarDecl (VarDeclArray . VarId $ Ident "new_context")+ (Just . InitExp $ mkContextCopy checked parentStackStart params)+ ])+ : ( map (\ (param, pos) ->+ BlockStmt . ExpStmt $+ Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])+ (Lit $ Int (toInteger pos)))+ EqualA+ (ExpName param)) $ zip paramNames [parentStackStart..]+ )+ ) + <$> mapM mkName params++mkContextCopy :: Bool -> Int -> [Name] -> Exp+mkContextCopy True parentStackStart params =+ MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])+ []+ (Ident "clone")+ []+mkContextCopy False parentStackStart params =+ MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])+ []+ (Ident "copyOf")+ [ ExpName $ J.Name [Ident "context"]+ , MethodInv+ $ TypeMethodCall (J.Name [Ident "Math"])+ []+ (Ident "max")+ [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])+ (Ident "length")+ , Lit . Int $ toInteger (parentStackStart + length params)+ ]+ ]++mkProjection :: LVar -> Int -> CodeGeneration Exp+mkProjection var memberNr =+ (\ var -> ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall+ (var)+ []+ (Ident "getData")+ []+ )+ (Lit $ Int (toInteger memberNr))+ )+ <$> mkVarAccess (Just idrisObjectType) var++type ClassName = String++mkPrimitive :: ClassName -> Literal -> Exp+mkPrimitive className value = + MethodInv $ TypeMethodCall (J.Name [Ident className]) + []+ (Ident "valueOf")+ [Lit $ value]++mkClass :: ClassType -> Exp+mkClass classType =+ ClassLit . Just . RefType .ClassRefType $ classType++mkBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp+mkBinOpExp castTo op (var:vars) = do+ start <- mkVarAccess (Just castTo) var+ foldM (\ exp var -> BinOp exp op <$> mkVarAccess (Just castTo) var) start vars++mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> CodeGeneration Exp+mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) = do+ start <- (mkVarAccess (Just castTo) var) + foldM (\ exp var -> resultTransformation + . BinOp (opTransformation exp) op + . opTransformation + <$> mkVarAccess (Just castTo) var) + start+ vars++mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> CodeGeneration Exp+mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args =+ mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls]) + [] + (Ident fromMethodName) + [exp]+ ) + (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls]) + [] + (Ident "valueOf") + [Cast (PrimType $ toType) exp]+ )+ fromType+ op + args++mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp+mkLogicalBinOpExp castTo op (var:vars) = do+ start <- mkVarAccess (Just castTo) var+ foldM (\ exp var -> mkBoolToNumber castTo . BinOp exp op <$> mkVarAccess (Just castTo) var) + start+ vars++mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp+mkMethodOpChain1 = mkMethodOpChain id++mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp+mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) = do+ start <- initialTransformation <$> mkVarAccess (Just $ castTo) arg+ foldM (\ exp arg' -> + resultTransformation + . MethodInv + . PrimaryMethodCall exp [] (Ident method)+ . (:[])+ <$> mkVarAccess (Just $ castTo) arg'+ )+ start+ args++mkBoolToNumber :: ClassType -> Exp -> Exp+mkBoolToNumber (ClassType [(Ident name, [])]) boolExp =+ Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0))++mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> CodeGeneration Exp+mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var = do+ (\ var sext -> + MethodInv $ TypeMethodCall (J.Name [toTypeName])+ []+ (Ident "valueOf")+ [ Cond ( BinOp (var)+ LThan+ (Lit $ Int 0)+ )+ ( BinOp (Lit $ Int (2^bits))+ Add+ (sext)+ )+ sext+ ]+ )+ <$> mkVarAccess (Just $ fromType) var+ <*> mkSignedExt' toMethod fromType var+ +mkSignedExt :: String -> ClassType -> ClassType -> LVar -> CodeGeneration Exp+mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var =+ (\ sext -> MethodInv $ TypeMethodCall (J.Name [toTypeName])+ []+ (Ident "valueOf")+ [ sext ]+ )+ <$> mkSignedExt' toMethod fromType var++mkSignedExt' :: String -> ClassType -> LVar -> CodeGeneration Exp+mkSignedExt' toMethod fromType var =+ (\ var -> MethodInv $ PrimaryMethodCall (var)+ [] + (Ident toMethod)+ []+ )+ <$> mkVarAccess (Just $ fromType) var++data SPartialOrder+ = SLt+ | SLe+ | SEq+ | SGe+ | SGt++mkPartialOrder :: SPartialOrder -> Exp -> Exp+mkPartialOrder SLt x = (BinOp (Lit $ Int (-1)) Equal x)+mkPartialOrder SLe x = + BinOp (BinOp (Lit $ Int (-1)) Equal x)+ COr+ (BinOp (Lit $ Int 0) Equal x)+mkPartialOrder SEq x = BinOp (Lit $ Int 0) Equal x+mkPartialOrder SGe x =+ BinOp (BinOp (Lit $ Int 1) Equal x)+ COr+ (BinOp (Lit $ Int 0) Equal x)+mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x)++varPos :: LVar -> CodeGeneration Integer+varPos (Loc i) = return (toInteger i)+varPos (Glob name) = do+ positions <- globalVariablePositions <$> get+ case lookup name positions of+ (Just pos) -> return pos+ Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name++mkVarAccess :: Maybe ClassType -> LVar -> CodeGeneration Exp+mkVarAccess Nothing var = + (\ pos -> ArrayAccess $ ArrayIndex (contextArray var) (Lit $ Int pos)) + <$> varPos var+mkVarAccess (Just castTo) var = + Cast (RefType . ClassRefType $ castTo) <$> (mkVarAccess Nothing var)++mkPrimitiveCast :: ClassType -> ClassType -> LVar -> CodeGeneration Exp+mkPrimitiveCast fromType (ClassType [(toType, [])]) var =+ (\ var -> + MethodInv $ TypeMethodCall (J.Name [toType])+ []+ (Ident "valueOf")+ [var]+ )+ <$> mkVarAccess (Just fromType) var++mkToString :: ClassType -> LVar -> CodeGeneration Exp+mkToString castTo var =+ (\ var -> MethodInv $ PrimaryMethodCall (var)+ []+ (Ident "toString")+ []+ )+ <$> mkVarAccess (Just castTo) var+data Std = In | Out | Err++instance Show Std where+ show In = "in"+ show Out = "out"+ show Err = "err"++mkSystemStd :: Std -> Exp+mkSystemStd std = FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "System"]) (Ident $ show std)++mkSystemOutPrint :: Exp -> Exp+mkSystemOutPrint value =+ MethodInv $ PrimaryMethodCall (mkSystemStd Out)+ []+ (Ident "print")+ [value]++mkMathFun :: String -> LVar -> CodeGeneration Exp+mkMathFun funName var =+ (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Double"])+ []+ (Ident "valueOf")+ [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])+ []+ (Ident funName)+ [var]+ ]+ )+ <$> mkVarAccess (Just doubleType) var++mkStringAtIndex :: LVar -> Exp -> CodeGeneration Exp+mkStringAtIndex var indexExp =+ (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Integer"]) + []+ (Ident "valueOf")+ [ MethodInv $ PrimaryMethodCall (var)+ []+ (Ident "charAt")+ [indexExp]+ ]+ )+ <$> mkVarAccess (Just stringType) var++mkForeignType :: FType -> Maybe ClassType+mkForeignType (FInt ty) = return (intTyToClass ty)+mkForeignType FChar = return integerType+mkForeignType FString = return stringType+mkForeignType FPtr = return objectType+mkForeignType FDouble = return doubleType+mkForeignType FAny = return objectType+mkForeignType FUnit = Nothing++mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp+mkForeignVarAccess (FInt ty) var = + (\ var -> MethodInv $ PrimaryMethodCall var+ []+ (Ident (intTyToMethod ty))+ []+ )+ <$> mkVarAccess (Just $ intTyToClass ty) var+mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FInt IT32) var+mkForeignVarAccess FDouble var = + (\ var -> MethodInv $ PrimaryMethodCall (var)+ []+ (Ident "doubleValue")+ []+ )+ <$> mkVarAccess (Just doubleType) var+mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var + +mkFromForeignType :: FType -> Exp -> Exp+mkFromForeignType (FInt ty) from = + MethodInv $ TypeMethodCall (J.Name [intTyToIdent ty])+ []+ (Ident "valueOf")+ [from]+mkFromForeignType FChar from = mkFromForeignType (FInt IT32) from+mkFromForeignType FDouble from = + MethodInv $ TypeMethodCall (J.Name [Ident "Double"])+ []+ (Ident "valueOf")+ [from]+mkFromForeignType _ from = from++mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> CodeGeneration Exp+mkForeignInvoke fType method args =+ (\ foreignInvokeMeth -> + MethodInv $ PrimaryMethodCall (InstanceCreation [] + objectType + [] + (Just $ ClassBody [ MemberDecl $ foreignInvokeMeth ])+ )+ []+ (Ident "foreignInvoke")+ []+ )+ <$> mkForeignInvokeMethod fType method args+++mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> CodeGeneration MemberDecl +mkForeignInvokeMethod fType method args =+ (\ tryBlock -> + MethodDecl [Public, Final]+ []+ (Just . RefType $ ClassRefType objectType)+ (Ident "foreignInvoke")+ []+ []+ (MethodBody . Just $ Block + [ BlockStmt + $ Try tryBlock+ [ Catch (FormalParam [] + (RefType $ ClassRefType exceptionType)+ False+ (VarId $ Ident "ex")+ )+ (Block [ BlockStmt + . Throw+ $ InstanceCreation []+ runtimeExceptionType+ [ExpName $ J.Name [Ident "ex"]]+ Nothing+ ]+ )+ ]+ Nothing+ ]+ )+ )+ <$> mkForeignInvokeTryBlock fType method args+++mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> CodeGeneration Block+mkForeignInvokeTryBlock FUnit method args =+ (\ method args -> Block [ BlockStmt . ExpStmt . MethodInv $ MethodCall method args+ , BlockStmt $ Return (Just $ Lit Null)+ ]+ )+ <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))+ (parser name method)+ )+ <*> mapM (uncurry mkForeignVarAccess) args+mkForeignInvokeTryBlock fType method args =+ (\ method args -> Block [ BlockStmt . Return + . Just + . mkFromForeignType fType+ . MethodInv + $ MethodCall method args+ ]+ )+ <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))+ (parser name method)+ )+ <*> mapM (uncurry mkForeignVarAccess) args++mkMethodClosure :: Name -> [LVar] -> CodeGeneration Exp+mkMethodClosure name args =+ (\ name args -> + InstanceCreation []+ idrisClosureType+ [ (ExpName $ J.Name [Ident "context"]) ]+ ( Just + $ ClassBody + [ MemberDecl + $ MethodDecl [Public, Final]+ []+ (Just . RefType $ ClassRefType objectType)+ (Ident "call")+ []+ []+ ( MethodBody + . Just + $ Block [ BlockStmt + . Return + . Just + . MethodInv + $ MethodCall (reverseNameSpace name) + args+ ]+ )+ ]+ )+ )+ <$> mkName name+ <*> mapM (mkExp . SV) args++mkThread :: LVar -> CodeGeneration Exp+mkThread arg =+ (\ eval -> + MethodInv + $ PrimaryMethodCall (InstanceCreation [] + (ClassType [(Ident "Thread", [])]) + [ eval ] + ( Just + $ ClassBody [ MemberDecl + $ MethodDecl [Public, Final]+ []+ (Just . RefType $ ClassRefType objectType)+ (Ident "_start")+ []+ []+ ( MethodBody + . Just + $ Block [ BlockStmt + . ExpStmt + . MethodInv + $ MethodCall (J.Name [Ident "start"])+ []+ , BlockStmt + . Return + . Just + $ This+ ]+ )+ ]+ )+ )+ []+ (Ident "_start")+ []+ )+ <$> mkThreadBinding arg++mkThreadBinding :: LVar -> CodeGeneration Exp+mkThreadBinding var =+ (\ bindingMethod var ->+ MethodInv $ PrimaryMethodCall ( InstanceCreation []+ objectType+ []+ (Just $ ClassBody [MemberDecl $ bindingMethod])+ )+ []+ (Ident "apply")+ [ var ]+ )+ <$> mkThreadBindingMethod+ <*> mkVarAccess Nothing var+++mkThreadBindingMethod :: CodeGeneration MemberDecl+mkThreadBindingMethod = + (\ compute -> + MethodDecl [Final, Public]+ []+ (Just . RefType $ ClassRefType idrisClosureType)+ (Ident "apply")+ [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ]+ []+ (MethodBody . Just $ Block+ [ mkThreadBindingStack+ , BlockStmt . Return $ Just compute+ ]+ )+ )+ <$> mkBindingClosure (SUpdate (Loc 0) (SApp False (MN 0 "EVAL") [Loc 0]))+++mkThreadBindingStack :: BlockStmt+mkThreadBindingStack =+ LocalVars [Final]+ objectArrayType+ [ VarDecl (VarDeclArray . VarId $ Ident "new_context")+ (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]])+ ]+ ++mkExp :: SExp -> CodeGeneration Exp+mkExp (SV var) = mkVarAccess Nothing var+mkExp (SApp False name args) =+ (\ methClosure ->+ MethodInv $ PrimaryMethodCall ( InstanceCreation []+ idrisTailCallClosureType+ [ methClosure ]+ Nothing+ )+ []+ (Ident "call")+ []+ )+ <$> mkMethodClosure name args+mkExp (SApp True name args) =+ (\ methClosure ->+ ( InstanceCreation []+ idrisTailCallClosureType+ [ methClosure ]+ Nothing+ )+ )+ <$> mkMethodClosure name args+mkExp (SLet var new old) =+ mkLet var old new+mkExp (SUpdate var exp) =+ (\ rhs varPos -> Assign (ArrayLhs $ ArrayIndex (contextArray var) (Lit $ Int varPos))+ EqualA+ rhs+ )+ <$> mkExp exp+ <*> varPos var+mkExp (SCon conId name args) =+ (\ args -> InstanceCreation []+ idrisObjectType+ ((Lit $ Int (toInteger conId)):args)+ Nothing)+ <$> mapM (mkExp .SV) args+mkExp (SCase var alts) = mkCase False var alts+mkExp (SChkCase var alts) = mkCase True var alts+mkExp (SProj var i) = mkProjection var i+mkExp (SConst (I x)) = + let x' :: Int32; x' = fromInteger (toInteger x) in+ return $ mkPrimitive "Integer" (Int (fromInteger (toInteger x')))+mkExp (SConst (BI x)) =+ return $ InstanceCreation [] + (ClassType [(Ident "BigInteger", [])])+ [Lit $ String (show x)]+ Nothing+mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)+mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)+mkExp (SConst (Str x)) = return $ Lit $ String x+mkExp (SConst IType) = return $ mkClass integerType+mkExp (SConst BIType) = return $ mkClass bigIntegerType+mkExp (SConst FlType) = return $ mkClass doubleType+mkExp (SConst ChType) = return $ mkClass charType+mkExp (SConst StrType) = return $ mkClass stringType+mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x))+mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x))+mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))+mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (String (show x))+mkExp (SConst (B8Type))= return $ mkClass byteType+mkExp (SConst (B16Type)) = return $ mkClass shortType+mkExp (SConst (B32Type)) = return $ mkClass integerType+mkExp (SConst (B64Type)) = return $ mkClass longType+mkExp (SConst (PtrType)) = return $ mkClass objectType+mkExp (SConst (VoidType)) = return $ mkClass voidType+mkExp (SConst (Forgot)) = return $ mkClass objectType+mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args+mkExp (SOp (LPlus ITNative) args) = mkExp (SOp (LPlus IT32) args)+mkExp (SOp (LMinus ITNative) args) = mkExp (SOp (LMinus IT32) args)+mkExp (SOp (LTimes ITNative) args) = mkExp (SOp (LTimes IT32) args)+mkExp (SOp (LSDiv ITNative) args) = mkExp (SOp (LSDiv IT32) args)+mkExp (SOp (LSRem ITNative) args) = mkExp (SOp (LSRem IT32) args)+mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd IT32) args)+mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr IT32) args)+mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr IT32) args)+mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl IT32) args)+mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL IT32) args)+mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR IT32) args)+mkExp (SOp (LEq ITNative) args) = mkExp (SOp (LEq IT32) args)+mkExp (SOp (LLt ITNative) args) = mkExp (SOp (LLt IT32) args)+mkExp (SOp (LLe ITNative) args) = mkExp (SOp (LLe IT32) args)+mkExp (SOp (LGt ITNative) args) = mkExp (SOp (LGt IT32) args)+mkExp (SOp (LGe ITNative) args) = mkExp (SOp (LGe IT32) args)+mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args+mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args+mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args+mkExp (SOp LFDiv args) = mkBinOpExp doubleType Div args+mkExp (SOp LFEq args) = + mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args+mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args+mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args+mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args+mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args+mkExp (SOp (LPlus ITBig) args) = mkMethodOpChain1 id bigIntegerType "add" args+mkExp (SOp (LMinus ITBig) args) = mkMethodOpChain1 id bigIntegerType "subtract" args+mkExp (SOp (LTimes ITBig) args) = mkMethodOpChain1 id bigIntegerType "multiply" args+mkExp (SOp (LSDiv ITBig) args) = mkMethodOpChain1 id bigIntegerType "divide" args+mkExp (SOp (LSRem ITBig) args) = mkMethodOpChain1 id bigIntegerType "mod" args+mkExp (SOp (LEq ITBig) args) = + mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args+mkExp (SOp (LLt ITBig) args) =+ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType + . mkPartialOrder SLt+ ) + bigIntegerType + "compareTo" + args+mkExp (SOp (LLe ITBig) args) =+ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType + . mkPartialOrder SLe+ ) + bigIntegerType + "compareTo" + args+mkExp (SOp (LGt ITBig) args) =+ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType + . mkPartialOrder SGt+ ) + bigIntegerType + "compareTo" + args+mkExp (SOp (LGe ITBig) args) =+ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType + . mkPartialOrder SGe+ ) + bigIntegerType + "compareTo" + args+mkExp (SOp LStrConcat args) =+ mkMethodOpChain (\ exp -> InstanceCreation [] + (ClassType [(Ident "StringBuilder", [])])+ [exp]+ Nothing+ )+ (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])+ stringType + "append"+ args+mkExp (SOp LStrLt args@[_, _]) =+ mkMethodOpChain1 ( mkBoolToNumber integerType+ . mkPartialOrder SLt+ )+ stringType+ "compareTo"+ args+mkExp (SOp LStrEq args@[_, _]) =+ mkMethodOpChain1 ( mkBoolToNumber integerType)+ stringType+ "equals"+ args+mkExp (SOp LStrLen [arg]) =+ (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])+ <$> mkVarAccess (Just stringType) arg+mkExp (SOp (LIntFloat ity) [arg]) =+ mkPrimitiveCast (intTyToClass ity) doubleType arg+mkExp (SOp (LFloatInt ity) [arg]) =+ mkPrimitiveCast doubleType (intTyToClass ity) arg+mkExp (SOp (LIntStr ITBig) [arg]) =+ (\ var -> InstanceCreation [] bigIntegerType [var] Nothing)+ <$> mkVarAccess (Just stringType) arg+mkExp (SOp (LIntStr ity) [arg]) =+ mkToString (intTyToClass ity) arg+mkExp (SOp (LStrInt ity) [arg]) =+ mkPrimitiveCast stringType (intTyToClass ity) arg+mkExp (SOp LFloatStr [arg]) =+ mkToString doubleType arg+mkExp (SOp LStrFloat [arg]) =+ mkPrimitiveCast doubleType stringType arg+mkExp (SOp (LSExt ITNative ITBig) [arg]) =+ mkPrimitiveCast integerType bigIntegerType arg+mkExp (SOp (LTrunc ITBig ITNative) [arg]) =+ mkPrimitiveCast bigIntegerType integerType arg+mkExp (SOp (LChInt ITNative) [arg]) =+ mkVarAccess (Just integerType) arg+mkExp (SOp (LIntCh ITNative) [arg]) =+ mkVarAccess (Just integerType) arg+mkExp (SOp LPrintNum [arg]) =+ mkSystemOutPrint <$> (mkVarAccess Nothing arg)+mkExp (SOp LPrintStr [arg]) =+ mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)+mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])+mkExp (SOp (LLt ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args+mkExp (SOp (LLe ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args+mkExp (SOp (LEq ty) args) = + mkMethodOpChain1 (mkBoolToNumber (intTyToClass ty)) (intTyToClass ty) "equals" args+mkExp (SOp (LGt ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args+mkExp (SOp (LGe ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args+mkExp (SOp (LPlus ty) args) = mkBinOpExp (intTyToClass ty) Add args+mkExp (SOp (LMinus ty) args) = mkBinOpExp (intTyToClass ty) Sub args+mkExp (SOp (LTimes ty) args) = mkBinOpExp (intTyToClass ty) Mult args+mkExp (SOp (LUDiv IT64) (arg:args)) = do+ (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)+ return $ foldl (\ exp arg ->+ MethodInv $ PrimaryMethodCall+ ( MethodInv $ PrimaryMethodCall+ ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])+ []+ (Ident "valueOf")+ [ exp ]+ )+ []+ (Ident "divide")+ [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])+ []+ (Ident "valueOf")+ [ arg ]+ ]+ )+ []+ (Ident "longValue")+ []+ ) + arg+ args+mkExp (SOp (LUDiv ty) args) = + mkBinOpExpConv (intTyToMethod $ nextIntTy ty) + (intTyToPrimTy $ nextIntTy ty) + (intTyToClass ty) + Div + args+mkExp (SOp (LSDiv ty) args) = mkBinOpExp (intTyToClass ty) Div args+mkExp (SOp (LURem IT64) (arg:args)) = do+ (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)+ return $ foldl (\ exp arg ->+ MethodInv $ PrimaryMethodCall+ ( MethodInv $ PrimaryMethodCall+ ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])+ []+ (Ident "valueOf")+ [ exp ]+ )+ []+ (Ident "remainder")+ [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])+ []+ (Ident "valueOf")+ [ arg ]+ ]+ )+ []+ (Ident "longValue")+ []+ ) + arg+ args+mkExp (SOp (LURem ty) args) =+ mkBinOpExpConv (intTyToMethod $ nextIntTy ty) + (intTyToPrimTy $ nextIntTy ty) + (intTyToClass ty)+ Rem+ args+mkExp (SOp (LSRem ty) args) = mkBinOpExp (intTyToClass ty) Rem args+mkExp (SOp (LSHL ty) args) = mkBinOpExp (intTyToClass ty) LShift args+mkExp (SOp (LLSHR ty) args) = mkBinOpExp (intTyToClass ty) RRShift args+mkExp (SOp (LASHR ty) args) = mkBinOpExp (intTyToClass ty) RShift args+mkExp (SOp (LAnd ty) args) = mkBinOpExp (intTyToClass ty) And args+mkExp (SOp (LOr ty) args) = mkBinOpExp (intTyToClass ty) Or args+mkExp (SOp (LXOr ty) args) = mkBinOpExp (intTyToClass ty) Xor args+mkExp (SOp (LCompl ty) [var]) = PreBitCompl <$> mkVarAccess (Just $ intTyToClass ty) var+mkExp (SOp (LZExt from to) [var])+ | intTyWidth from < intTyWidth to+ = mkZeroExt (intTyToMethod to) (intTyWidth from) (intTyToClass from) (intTyToClass to) var+mkExp (SOp (LSExt from to) [var])+ | intTyWidth from < intTyWidth to+ = mkSignedExt (intTyToMethod to) (intTyToClass from) (intTyToClass to) var+mkExp (SOp (LTrunc from to) [var])+ | intTyWidth from > intTyWidth to+ = (\ var -> MethodInv $ + TypeMethodCall (J.Name [intTyToIdent to])+ []+ (Ident "valueOf")+ [ MethodInv + $ PrimaryMethodCall var [] (Ident (intTyToMethod to)) [] ]+ )+ <$> mkVarAccess (Just $ intTyToClass from) var+mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg+mkExp (SOp LFLog [arg]) = mkMathFun "log" arg+mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg+mkExp (SOp LFCos [arg]) = mkMathFun "cos" arg+mkExp (SOp LFTan [arg]) = mkMathFun "tan" arg+mkExp (SOp LFASin [arg]) = mkMathFun "asin" arg+mkExp (SOp LFACos [arg]) = mkMathFun "acos" arg+mkExp (SOp LFATan [arg]) = mkMathFun "atan" arg+mkExp (SOp LFSqrt [arg]) = mkMathFun "sqrt" arg+mkExp (SOp LFFloor [arg]) = mkMathFun "floor" arg+mkExp (SOp LFCeil [arg]) = mkMathFun "ceil" arg+mkExp (SOp LStrHead [arg]) = mkStringAtIndex arg (Lit $ Int 0)+mkExp (SOp LStrTail [arg]) = + (\ var -> MethodInv $ PrimaryMethodCall (var)+ []+ (Ident "substring")+ [Lit $ Int 1]+ ) + <$> mkVarAccess (Just stringType) arg+mkExp (SOp LStrCons [c, cs]) =+ (\ cVar csVar -> MethodInv $ + PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation [] + (ClassType [(Ident "StringBuilder", [])])+ [csVar]+ Nothing+ )+ []+ (Ident "insert")+ [ Lit $ Int 0, + Cast (PrimType CharT) + (MethodInv $ PrimaryMethodCall + (cVar)+ []+ (Ident "intValue")+ []+ )+ ]+ )+ []+ (Ident "toString")+ []+ )+ <$> mkVarAccess (Just integerType) c+ <*> mkVarAccess (Just stringType) cs+mkExp (SOp LStrIndex [str, i]) = mkVarAccess (Just integerType) i >>= mkStringAtIndex str +mkExp (SOp LStrRev [str]) = + (\ var -> MethodInv $ + PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []+ (ClassType [(Ident "StringBuffer", [])])+ [var]+ Nothing+ )+ []+ (Ident "reverse")+ []+ )+ []+ (Ident "toString")+ []+ )+ <$> mkVarAccess (Just stringType) str+mkExp (SOp LStdIn []) = return $ mkSystemStd In+mkExp (SOp LStdOut []) = return $ mkSystemStd Out+mkExp (SOp LStdErr []) = return $ mkSystemStd Err+mkExp (SOp LFork [arg]) = mkThread arg+mkExp (SOp LPar [arg]) = mkExp (SV arg)+mkExp (SOp LVMPtr []) = + return $ MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []+mkExp (SOp LNoOp args) = mkExp . SV $ last args+mkExp (SNothing) = return $ Lit Null+mkExp (SError err) =+ return . MethodInv $ + PrimaryMethodCall (InstanceCreation [] + runtimeExceptionType + [Lit $ String err]+ ( Just $ ClassBody+ [ MemberDecl $ MethodDecl [Public, Final]+ []+ (Just . RefType $ ClassRefType objectType)+ (Ident "throwSelf")+ []+ []+ ( MethodBody . Just $+ Block [ BlockStmt (Throw This) ]+ )+ ]+ )+ )+ []+ (Ident "throwSelf")+ []+mkExp other = error (show other)
src/IRTS/CodegenJavaScript.hs view
@@ -139,6 +139,7 @@ translateConstant StrType = "__IDRRT__.String" translateConstant BIType = "__IDRRT__.Integer" translateConstant FlType = "__IDRRT__.Float"+translateConstant PtrType = "__IDRRT__.Ptr" translateConstant Forgot = "__IDRRT__.Forgot" translateConstant c = "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"@@ -202,58 +203,58 @@ ++ ";\n});" translateExpression (SOp op vars)- | LPlus <- op+ | (LPlus _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs- | LMinus <- op+ | (LMinus _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs- | LTimes <- op+ | (LTimes _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs- | LDiv <- op+ | (LSDiv _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs- | LMod <- op+ | (LSRem _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs- | LEq <- op+ | (LEq _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs- | LLt <- op+ | (LLt _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs- | LLe <- op+ | (LLe _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs- | LGt <- op+ | (LGt _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs- | LGe <- op+ | (LGe _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs- | LAnd <- op+ | (LAnd _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs- | LOr <- op+ | (LOr _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs- | LXOr <- op+ | (LXOr _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs- | LSHL <- op+ | (LSHL _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs- | LSHR <- op+ | (LASHR _) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs- | LCompl <- op+ | (LCompl _) <- op , (arg:_) <- vars = '~' : translateVariableName arg - | LBPlus <- op+ | (LPlus ITBig) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"- | LBMinus <- op+ | (LMinus ITBig) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"- | LBTimes <- op+ | (LTimes ITBig) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"- | LBDiv <- op+ | (LSDiv ITBig) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"- | LBMod <- op+ | (LSRem ITBig) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"- | LBEq <- op+ | (LEq ITBig) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"- | LBLt <- op+ | (LLt ITBig) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"- | LBLe <- op+ | (LLe ITBig) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"- | LBGt <- op+ | (LGt ITBig) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"- | LBGe <- op+ | (LGe ITBig) <- op , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")" | LFPlus <- op@@ -284,29 +285,29 @@ | LStrLen <- op , (arg:_) <- vars = translateVariableName arg ++ ".length" - | LStrInt <- op+ | (LStrInt ITNative) <- op , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"- | LIntStr <- op+ | (LIntStr ITNative) <- op , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"- | LIntBig <- op+ | (LSExt ITNative ITBig) <- op , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"- | LBigInt <- op+ | (LTrunc ITBig ITNative) <- op , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"- | LBigStr <- op+ | (LIntStr ITBig) <- op , (arg:_) <- vars = translateVariableName arg ++ ".toString()"- | LStrBig <- op+ | (LStrInt ITBig) <- op , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")" | LFloatStr <- op , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")" | LStrFloat <- op , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"- | LIntFloat <- op+ | (LIntFloat ITNative) <- op , (arg:_) <- vars = translateVariableName arg- | LFloatInt <- op+ | (LFloatInt ITNative) <- op , (arg:_) <- vars = translateVariableName arg- | LChInt <- op+ | (LChInt ITNative) <- op , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"- | LIntCh <- op+ | (LIntCh ITNative) <- op , (arg:_) <- vars = "String.fromCharCode(" ++ translateVariableName arg ++ ")" @@ -385,11 +386,11 @@ , (obj:as) <- args = concat [object obj, method, arguments as] - | "[]=" == fun+ | "[]=" `isSuffixOf` fun , (idx:val:[]) <- args = concat [array, index idx, assign val] - | "[]" == fun+ | "[]" `isSuffixOf` fun , (idx:[]) <- args = array ++ index idx @@ -450,7 +451,7 @@ | IType <- ty = matchHelper "Int" | BIType <- ty = matchHelper "Integer" | FlType <- ty = matchHelper "Float"- | PtrType <- ty = matchHelper "Pointer"+ | PtrType <- ty = matchHelper "Ptr" | Forgot <- ty = matchHelper "Forgot" where matchHelper tyName = translateTypeMatch var tyName e
src/IRTS/Compiler.hs view
@@ -71,7 +71,7 @@ (concatMap mkObj objs) (concatMap mkLib libs) NONE ViaJava ->- codegenJava c f outty+ codegenJava [] c f hdrs libs outty ViaJavaScript -> codegenJavaScript JavaScript c f outty ViaNode -> @@ -98,7 +98,7 @@ allNames :: [Name] -> Name -> Idris [Name] allNames ns n | n `elem` ns = return [] allNames ns n = do i <- getIState- case lookupCtxt Nothing n (idris_callgraph i) of+ case lookupCtxt n (idris_callgraph i) of [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns')) return (nub (n : concat more)) _ -> return [n]@@ -169,6 +169,8 @@ | (P _ (UN "lazy") _, [_, arg]) <- unApply tm = do arg' <- ir' env arg return $ LLazyExp arg'+ | (P _ (UN "assert_smaller") _, [_, _, _, arg]) <- unApply tm+ = ir' env arg | (P _ (UN "par") _, [_, arg]) <- unApply tm = do arg' <- ir' env arg return $ LOp LPar [LLazyExp arg']@@ -205,12 +207,12 @@ Just tm -> return tm _ -> do let collapse - = case lookupCtxt Nothing n + = case lookupCtxt n (idris_optimisation i) of [oi] -> collapsible oi _ -> False let unused - = case lookupCtxt Nothing n + = case lookupCtxt n (idris_callgraph i) of [CGInfo _ _ _ _ unusedpos] -> unusedpos@@ -264,31 +266,40 @@ doForeign :: [Name] -> [TT Name] -> Idris LExp doForeign env (_ : fgn : args) | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn- = let tys = getFTypes fgnArgTys+ = let maybeTys = getFTypes fgnArgTys rty = mkIty' ret in- do args' <- mapM (ir' env) args- -- wrap it in a prim__IO- -- return $ con_ 0 @@ impossible @@ - return $ -- LLazyExp $- LForeign LANG_C rty fgnName (zip tys args')+ case maybeTys of+ Nothing -> fail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)+ Just tys -> do+ args' <- mapM (ir' env) args+ -- wrap it in a prim__IO+ -- return $ con_ 0 @@ impossible @@+ return $ -- LLazyExp $+ LForeign LANG_C rty fgnName (zip tys args') | otherwise = fail "Badly formed foreign function call" -getFTypes :: TT Name -> [FType]+getFTypes :: TT Name -> Maybe [FType] getFTypes tm = case unApply tm of- (nil, []) -> []+ (nil, []) -> Just [] (cons, [ty, xs]) -> - let rest = getFTypes xs in- mkIty' ty : rest+ fmap (mkIty' ty :) (getFTypes xs)+ _ -> Nothing mkIty' (P _ (UN ty) _) = mkIty ty+mkIty' (App (P _ (UN "FIntT") _) (P _ (UN intTy) _)) = mkIntIty intTy mkIty' _ = FAny -mkIty "FInt" = FInt mkIty "FFloat" = FDouble mkIty "FChar" = FChar mkIty "FString" = FString mkIty "FPtr" = FPtr mkIty "FUnit" = FUnit++mkIntIty "ITNative" = FInt ITNative+mkIntIty "IT8" = FInt IT8+mkIntIty "IT16" = FInt IT16+mkIntIty "IT32" = FInt IT32+mkIntIty "IT64" = FInt IT64 zname = NS (UN "O") ["Nat","Prelude"] sname = NS (UN "S") ["Nat","Prelude"]
src/IRTS/Defunctionalise.hs view
@@ -80,14 +80,14 @@ -- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e aa env (LApp tc (LV (Glob n)) args) = do args' <- mapM (aa env) args - case lookupCtxt Nothing n defs of+ case lookupCtxt n defs of [LConstructor _ i ar] -> return $ DApp tc n args' [LFun _ _ as _] -> let arity = length as in fixApply tc n args' arity [] -> return $ chainAPPLY (DV (Glob n)) args' aa env (LLazyApp n args) = do args' <- mapM (aa env) args- case lookupCtxt Nothing n defs of+ case lookupCtxt n defs of [LConstructor _ i ar] -> return $ DApp False n args' [LFun _ _ as _] -> let arity = length as in fixLazyApply n args' arity
src/IRTS/LParser.hs view
@@ -61,7 +61,7 @@ case checked of OK c -> case tgt of ViaC -> codegenC c "a.out" outty ["math.h"] "" "" TRACE- ViaJava -> codegenJava c "a.out" outty+ ViaJava -> codegenJava [] c "a.out" [] [] outty Error e -> fail $ show e parseFOVM :: FilePath -> IO [(Name, LDecl)]@@ -92,39 +92,39 @@ pLExp = buildExpressionParser optable pLExp' -optable = [[binary "*" (\x y -> LOp LTimes [x,y]) AssocLeft,- binary "/" (\x y -> LOp LDiv [x,y]) AssocLeft,+optable = [[binary "*" (\x y -> LOp (LTimes ITNative) [x,y]) AssocLeft,+ binary "/" (\x y -> LOp (LSDiv ITNative) [x,y]) AssocLeft, binary "*." (\x y -> LOp LFTimes [x,y]) AssocLeft, binary "/." (\x y -> LOp LFDiv [x,y]) AssocLeft,- binary "*:" (\x y -> LOp LBTimes [x,y]) AssocLeft,- binary "/:" (\x y -> LOp LBDiv [x,y]) AssocLeft+ binary "*:" (\x y -> LOp (LTimes ITBig) [x,y]) AssocLeft,+ binary "/:" (\x y -> LOp (LSDiv ITBig) [x,y]) AssocLeft ], [- binary "+" (\x y -> LOp LPlus [x,y]) AssocLeft,- binary "-" (\x y -> LOp LMinus [x,y]) AssocLeft,+ binary "+" (\x y -> LOp (LPlus ITNative) [x,y]) AssocLeft,+ binary "-" (\x y -> LOp (LMinus ITNative) [x,y]) AssocLeft, binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft, binary "+." (\x y -> LOp LFPlus [x,y]) AssocLeft, binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft,- binary "+:" (\x y -> LOp LBPlus [x,y]) AssocLeft,- binary "-:" (\x y -> LOp LBMinus [x,y]) AssocLeft+ binary "+:" (\x y -> LOp (LPlus ITBig) [x,y]) AssocLeft,+ binary "-:" (\x y -> LOp (LMinus ITBig) [x,y]) AssocLeft ], [- binary "==" (\x y -> LOp LEq [x, y]) AssocNone,+ binary "==" (\x y -> LOp (LEq ITNative) [x, y]) AssocNone, binary "==." (\x y -> LOp LFEq [x, y]) AssocNone,- binary "<" (\x y -> LOp LLt [x, y]) AssocNone,+ binary "<" (\x y -> LOp (LLt ITNative) [x, y]) AssocNone, binary "<." (\x y -> LOp LFLt [x, y]) AssocNone,- binary ">" (\x y -> LOp LGt [x, y]) AssocNone,+ binary ">" (\x y -> LOp (LGt ITNative) [x, y]) AssocNone, binary ">." (\x y -> LOp LFGt [x, y]) AssocNone,- binary "<=" (\x y -> LOp LLe [x, y]) AssocNone,+ binary "<=" (\x y -> LOp (LLe ITNative) [x, y]) AssocNone, binary "<=." (\x y -> LOp LFLe [x, y]) AssocNone,- binary ">=" (\x y -> LOp LGe [x, y]) AssocNone,+ binary ">=" (\x y -> LOp (LGe ITNative) [x, y]) AssocNone, binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone, - binary "==:" (\x y -> LOp LBEq [x, y]) AssocNone,- binary "<:" (\x y -> LOp LBLt [x, y]) AssocNone,- binary ">:" (\x y -> LOp LBGt [x, y]) AssocNone,- binary "<=:" (\x y -> LOp LBLe [x, y]) AssocNone,- binary ">=:" (\x y -> LOp LBGe [x, y]) AssocNone+ binary "==:" (\x y -> LOp (LEq ITBig) [x, y]) AssocNone,+ binary "<:" (\x y -> LOp (LLt ITBig) [x, y]) AssocNone,+ binary ">:" (\x y -> LOp (LGt ITBig) [x, y]) AssocNone,+ binary "<=:" (\x y -> LOp (LLe ITBig) [x, y]) AssocNone,+ binary ">=:" (\x y -> LOp (LGe ITBig) [x, y]) AssocNone ]] binary name f assoc = Infix (do reservedOp name; return f) assoc@@ -164,7 +164,7 @@ pLang = do reserved "C"; return LANG_C -pType = do reserved "Int"; return FInt+pType = do reserved "Int"; return (FInt ITNative) <|> do reserved "Float"; return FDouble <|> do reserved "String"; return FString <|> do reserved "Unit"; return FUnit@@ -184,21 +184,21 @@ <|> do reserved "StringFloat"; lchar '('; e <- pLExp; lchar ')' return (LOp LStrFloat [e]) <|> do reserved "FloatInt"; lchar '('; e <- pLExp; lchar ')'- return (LOp LFloatInt [e])+ return (LOp (LFloatInt ITNative) [e]) <|> do reserved "IntFloat"; lchar '('; e <- pLExp; lchar ')'- return (LOp LIntFloat [e])+ return (LOp (LIntFloat ITNative) [e]) <|> do reserved "StringInt"; lchar '('; e <- pLExp; lchar ')'- return (LOp LStrInt [e])+ return (LOp (LStrInt ITNative) [e]) <|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')'- return (LOp LIntStr [e])+ return (LOp (LIntStr ITNative) [e]) <|> do reserved "BigInt"; lchar '('; e <- pLExp; lchar ')'- return (LOp LBigInt [e])+ return (LOp (LTrunc ITBig ITNative) [e]) <|> do reserved "IntBig"; lchar '('; e <- pLExp; lchar ')'- return (LOp LIntBig [e])+ return (LOp (LSExt ITNative ITBig) [e]) <|> do reserved "BigString"; lchar '('; e <- pLExp; lchar ')'- return (LOp LBigStr [e])+ return (LOp (LIntStr ITBig) [e]) <|> do reserved "StringBig"; lchar '('; e <- pLExp; lchar ')'- return (LOp LStrBig [e])+ return (LOp (LStrInt ITBig) [e]) pPrim :: LParser LExp pPrim = do reserved "StrEq"; lchar '(';
src/IRTS/Lang.hs view
@@ -3,6 +3,7 @@ import Core.TT import Control.Monad.State hiding(lift) import Data.List+import Foreign.Storable (sizeOf) import Debug.Trace data LVar = Loc Int | Glob Name@@ -28,36 +29,38 @@ -- Primitive operators. Backends are not *required* to implement all -- of these, but should report an error if they are unable -data PrimFn = LPlus | LMinus | LTimes | LDiv | LMod - | LAnd | LOr | LXOr | LCompl | LSHL| LSHR- | LEq | LLt | LLe | LGt | LGe+data IntTy = ITNative | IT8 | IT16 | IT32 | IT64 | ITBig+ deriving (Show, Eq)++intTyWidth :: IntTy -> Int+intTyWidth IT8 = 8+intTyWidth IT16 = 16+intTyWidth IT32 = 32+intTyWidth IT64 = 64+intTyWidth ITNative = 8 * sizeOf (0 :: Int)+intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width"++intTyToConst :: IntTy -> Const+intTyToConst IT8 = B8Type+intTyToConst IT16 = B16Type+intTyToConst IT32 = B32Type+intTyToConst IT64 = B64Type+intTyToConst ITBig = BIType+intTyToConst ITNative = IType++data PrimFn = LPlus IntTy | LMinus IntTy | LTimes IntTy+ | LUDiv IntTy | LSDiv IntTy | LURem IntTy | LSRem IntTy+ | LAnd IntTy | LOr IntTy | LXOr IntTy | LCompl IntTy+ | LSHL IntTy | LLSHR IntTy | LASHR IntTy+ | LEq IntTy | LLt IntTy | LLe IntTy | LGt IntTy | LGe IntTy+ | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy | LFPlus | LFMinus | LFTimes | LFDiv | LFEq | LFLt | LFLe | LFGt | LFGe- | LBPlus | LBMinus | LBDec | LBTimes | LBDiv | LBMod - | LBEq | LBLt | LBLe | LBGt | LBGe | LStrConcat | LStrLt | LStrEq | LStrLen- | LIntFloat | LFloatInt | LIntStr | LStrInt | LFloatStr | LStrFloat- | LIntBig | LBigInt | LStrBig | LBigStr | LChInt | LIntCh+ | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy+ | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy | LPrintNum | LPrintStr | LReadStr - | LB8Lt | LB8Lte | LB8Eq | LB8Gt | LB8Gte- | LB8Plus | LB8Minus | LB8Times | LB8UDiv | LB8SDiv | LB8URem | LB8SRem- | LB8Shl | LB8LShr | LB8AShr | LB8And | LB8Or | LB8Xor | LB8Compl- | LB8Z16 | LB8Z32 | LB8Z64 | LB8S16 | LB8S32 | LB8S64 -- Zero/Sign extension- | LB16Lt | LB16Lte | LB16Eq | LB16Gt | LB16Gte- | LB16Plus | LB16Minus | LB16Times | LB16UDiv | LB16SDiv | LB16URem | LB16SRem- | LB16Shl | LB16LShr | LB16AShr | LB16And | LB16Or | LB16Xor | LB16Compl- | LB16Z32 | LB16Z64 | LB16S32 | LB16S64 | LB16T8 -- and Truncation- | LB32Lt | LB32Lte | LB32Eq | LB32Gt | LB32Gte- | LB32Plus | LB32Minus | LB32Times | LB32UDiv | LB32SDiv | LB32URem | LB32SRem- | LB32Shl | LB32LShr | LB32AShr | LB32And | LB32Or | LB32Xor | LB32Compl- | LB32Z64 | LB32S64 | LB32T8 | LB32T16- | LB64Lt | LB64Lte | LB64Eq | LB64Gt | LB64Gte- | LB64Plus | LB64Minus | LB64Times | LB64UDiv | LB64SDiv | LB64URem | LB64SRem- | LB64Shl | LB64LShr | LB64AShr | LB64And | LB64Or | LB64Xor | LB64Compl- | LB64T8 | LB64T16 | LB64T32- | LIntB8 | LIntB16 | LIntB32 | LIntB64 | LB32Int- | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan | LFSqrt | LFFloor | LFCeil @@ -76,7 +79,7 @@ data FLang = LANG_C deriving (Show, Eq) -data FType = FInt | FChar | FString | FUnit | FPtr | FDouble | FAny+data FType = FInt IntTy | FChar | FString | FUnit | FPtr | FDouble | FAny deriving (Show, Eq) data LAlt = LConCase Int Name [Name] LExp
src/IRTS/Simplified.hs view
@@ -46,7 +46,7 @@ simplify tl (DV (Loc i)) = return (SV (Loc i)) simplify tl (DV (Glob x)) = do ctxt <- ldefs- case lookupCtxt Nothing x ctxt of+ case lookupCtxt x ctxt of [DConstructor _ t 0] -> return $ SCon t x [] _ -> return $ SV (Glob x) simplify tl (DApp tc n args) = do args' <- mapM sVar args@@ -88,7 +88,7 @@ sVar (DV (Glob x)) = do ctxt <- ldefs- case lookupCtxt Nothing x ctxt of+ case lookupCtxt x ctxt of [DConstructor _ t 0] -> sVar (DC t x []) _ -> return (Glob x, Nothing) sVar (DV x) = return (x, Nothing)@@ -136,7 +136,7 @@ sc env (SV (Glob n)) = case lookup n (reverse env) of -- most recent first Just i -> do lvar i; return (SV (Loc i))- Nothing -> case lookupCtxt Nothing n ctxt of+ Nothing -> case lookupCtxt n ctxt of [DConstructor _ i ar] -> if True -- ar == 0 then return (SCon i n [])@@ -146,7 +146,7 @@ [] -> fail $ "Codegen error: No such variable " ++ show n sc env (SApp tc f args) = do args' <- mapM (scVar env) args- case lookupCtxt Nothing f ctxt of+ case lookupCtxt f ctxt of [DConstructor n tag ar] -> if True -- (ar == length args) then return $ SCon tag n args'@@ -160,7 +160,7 @@ return $ SForeign l ty f args' sc env (SCon tag f args) = do args' <- mapM (scVar env) args- case lookupCtxt Nothing f ctxt of+ case lookupCtxt f ctxt of [DConstructor n tag ar] -> if True -- (ar == length args) then return $ SCon tag n args'@@ -197,7 +197,7 @@ scVar env (Glob n) = case lookup n (reverse env) of -- most recent first Just i -> do lvar i; return (Loc i)- Nothing -> case lookupCtxt Nothing n ctxt of+ Nothing -> case lookupCtxt n ctxt of [DConstructor _ i ar] -> fail $ "Codegen error : can't pass constructor here" [_] -> return (Glob n)@@ -207,7 +207,7 @@ scalt env (SConCase _ i n args e) = do let env' = env ++ zip args [length env..]- tag <- case lookupCtxt Nothing n ctxt of+ tag <- case lookupCtxt n ctxt of [DConstructor _ i ar] -> if True -- (length args == ar) then return i
src/Idris/AbsSyntax.hs view
@@ -8,7 +8,9 @@ import Core.Elaborate hiding (Tactic(..)) import Core.Typecheck import Idris.AbsSyntaxTree+import Idris.IdeSlave import IRTS.CodegenCommon+import Util.DynamicLinker import Paths_idris @@ -23,7 +25,7 @@ import Debug.Trace import Util.Pretty-+import Util.System getContext :: Idris Context getContext = do i <- getIState; return (tt_ctxt i)@@ -40,9 +42,22 @@ addLib :: String -> Idris () addLib f = do i <- getIState; putIState $ i { idris_libs = f : idris_libs i } +addDyLib :: [String] -> Idris (Either DynamicLib String)+addDyLib libs = do i <- getIState+ handle <- lift $ mapM (\l -> catchIO (tryLoadLib l) (\_ -> return Nothing)) libs+ case msum handle of+ Nothing -> return (Right $ "Could not load dynamic alternatives \"" +++ concat (intersperse "," libs) ++ "\"")+ Just x -> do let ls = idris_dynamic_libs i+ putIState $ i { idris_dynamic_libs = x:ls }+ return (Left x)+ addHdr :: String -> Idris () addHdr f = do i <- getIState; putIState $ i { idris_hdrs = f : idris_hdrs i } +addLangExt :: LanguageExt -> Idris ()+addLangExt TypeProviders = do i <- getIState ; putIState $ i { idris_language_extensions = [TypeProviders] }+ totcheck :: (FC, Name) -> Idris () totcheck n = do i <- getIState; putIState $ i { idris_totcheck = idris_totcheck i ++ [n] } @@ -76,7 +91,7 @@ findCoercions fn cs where findCoercions t [] = [] findCoercions t (n : ns) =- let ps = case lookupTy Nothing n (tt_ctxt i) of+ let ps = case lookupTy n (tt_ctxt i) of [ty] -> case unApply (getRetTy ty) of (t', _) -> if t == t' then [n] else []@@ -107,7 +122,7 @@ addInstance :: Bool -> Name -> Name -> Idris () addInstance int n i = do ist <- getIState- case lookupCtxt Nothing n (idris_classes ist) of+ case lookupCtxt n (idris_classes ist) of [CI a b c d ins] -> do let cs = addDef n (CI a b c d (addI i ins)) (idris_classes ist) putIState $ ist { idris_classes = cs }@@ -127,7 +142,7 @@ addClass :: Name -> ClassInfo -> Idris () addClass n i = do ist <- getIState- let i' = case lookupCtxt Nothing n (idris_classes ist) of+ let i' = case lookupCtxt n (idris_classes ist) of [c] -> c { class_instances = class_instances i } _ -> i putIState $ ist { idris_classes = addDef n i' (idris_classes ist) }@@ -181,7 +196,7 @@ checkUndefined :: FC -> Name -> Idris () checkUndefined fc n = do i <- getContext- case lookupTy Nothing n i of+ case lookupTy n i of (_:_) -> fail $ show fc ++ ":" ++ show n ++ " already defined" _ -> return ()@@ -189,7 +204,7 @@ isUndefined :: FC -> Name -> Idris Bool isUndefined fc n = do i <- getContext- case lookupTy Nothing n i of+ case lookupTy n i of (_:_) -> return False _ -> return True @@ -208,10 +223,14 @@ let ics = zip cs (repeat fc) ++ idris_constraints i putIState $ i { tt_ctxt = ctxt', idris_constraints = ics } -addDeferred :: [(Name, Type)] -> Idris ()-addDeferred ns = do mapM_ (\(n, t) -> updateContext (addTyDecl n (tidyNames [] t))) ns- i <- getIState- putIState $ i { idris_metavars = map fst ns ++ idris_metavars i }+addDeferred = addDeferred' Ref+addDeferredTyCon = addDeferred' (TCon 0 0)++addDeferred' :: NameType -> [(Name, Type)] -> Idris ()+addDeferred' nt ns + = do mapM_ (\(n, t) -> updateContext (addTyDecl n nt (tidyNames [] t))) ns+ i <- getIState+ putIState $ i { idris_metavars = map fst ns ++ idris_metavars i } where tidyNames used (Bind (MN i x) b sc) = let n' = uniqueName (UN x) used in Bind n' b $ tidyNames (n':used) sc@@ -224,11 +243,44 @@ solveDeferred n = do i <- getIState putIState $ i { idris_metavars = idris_metavars i \\ [n] } +iResult :: String -> Idris ()+iResult s = do i <- getIState+ case idris_outputmode i of+ RawOutput -> case s of+ "" -> return ()+ s -> liftIO $ putStrLn s+ IdeSlave n ->+ let good = SexpList [SymbolAtom "ok", toSExp s] in+ liftIO $ putStrLn $ convSExp "return" good n++iFail :: String -> Idris ()+iFail s = do i <- getIState+ case idris_outputmode i of+ RawOutput -> case s of+ "" -> return ()+ s -> liftIO $ putStrLn s+ IdeSlave n ->+ let good = SexpList [SymbolAtom "error", toSExp s] in+ liftIO $ putStrLn $ convSExp "return" good n+ iputStrLn :: String -> Idris ()-iputStrLn = liftIO . putStrLn+iputStrLn s = do i <- getIState+ case idris_outputmode i of+ RawOutput -> liftIO $ putStrLn s+ IdeSlave n ->+ case span (/=':') s of+ (fn, ':':rest) -> case span isDigit rest of+ ([], ':':msg) -> write+ ([], msg) -> write+ (num, ':':msg) -> iWarn (FC fn (read num)) msg+ _ -> write+ where write = liftIO $ putStrLn $ convSExp "write-string" s n iWarn :: FC -> String -> Idris ()-iWarn fc err = liftIO $ putStrLn (show fc ++ ":" ++ err)+iWarn fc err = do i <- getIState+ case idris_outputmode i of+ RawOutput -> liftIO $ putStrLn (show fc ++ ":" ++ err)+ IdeSlave n -> liftIO $ putStrLn $ convSExp "warning" (fc_fname fc, fc_line fc, err) n setLogLevel :: Int -> Idris () setLogLevel l = do i <- getIState@@ -279,6 +331,12 @@ let opt' = opts { opt_repl = t } putIState $ i { idris_options = opt' } +setQuiet :: Bool -> Idris ()+setQuiet q = do i <- getIState+ let opts = idris_options i+ let opt' = opts { opt_quiet = q }+ putIState $ i { idris_options = opt' }+ setTarget :: Target -> Idris () setTarget t = do i <- getIState let opts = idris_options i@@ -299,6 +357,11 @@ outputTy = do i <- getIState return $ opt_outputTy $ idris_options i +setIdeSlave :: Bool -> Idris ()+setIdeSlave True = do i <- getIState+ putIState $ i { idris_outputmode = (IdeSlave 0) }+setIdeSlave False = return ()+ verbose :: Idris Bool verbose = do i <- getIState return (opt_verbose (idris_options i))@@ -352,7 +415,7 @@ allImportDirs :: IState -> Idris [FilePath] allImportDirs i = do let optdirs = opt_importdirs (idris_options i)- return ("." : optdirs)+ return ("." : reverse optdirs) impShow :: Idris Bool impShow = do i <- getIState@@ -497,6 +560,7 @@ PLet n' (en ty) (en v) (en (shadow n n' s)) | otherwise = PLet n (en ty) (en v) (en s) en (PEq f l r) = PEq f (en l) (en r)+ en (PRewrite f l r) = PRewrite f (en l) (en r) en (PTyped l r) = PTyped (en l) (en r) en (PPair f l r) = PPair f (en l) (en r) en (PDPair f l t r) = PDPair f (en l) (en t) (en r)@@ -622,7 +686,7 @@ getPriority i tm = 1 -- pri tm where pri (PRef _ n) =- case lookupP Nothing n (tt_ctxt i) of+ case lookupP n (tt_ctxt i) of ((P (DCon _ _) _ _):_) -> 1 ((P (TCon _ _) _ _):_) -> 1 ((P Ref _ _):_) -> 1@@ -632,6 +696,7 @@ 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)) pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as))) pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as))) pri (PTyped l r) = pri l@@ -668,6 +733,45 @@ -- Dealing with implicit arguments +-- Add constraint bindings from using block++addUsingConstraints :: SyntaxInfo -> FC -> PTerm -> Idris PTerm+addUsingConstraints syn fc t + = do ist <- get+ let ns = namesIn [] ist t+ let cs = getConstraints t -- check declared constraints+ let addconsts = uconsts \\ cs+ -- if all names in the arguments of addconsts appear in ns,+ -- add the constraint implicitly+ return (doAdd addconsts ns t)+ where uconsts = filter uconst (using syn)+ uconst (UConstraint _ _) = True+ uconst _ = False++ doAdd [] _ t = t+ -- if all of args in ns, then add it+ doAdd (UConstraint c args : cs) ns t+ | all (\n -> elem n ns) args + = PPi (Constraint False Dynamic "") (MN 0 "cu")+ (mkConst c args) (doAdd cs ns t)+ | otherwise = doAdd cs ns t++ mkConst c args = PApp fc (PRef fc c) + (map (\n -> PExp 0 False (PRef fc n) "") args)++ getConstraints (PPi (Constraint _ _ _) _ c sc)+ = getcapp c ++ getConstraints sc+ getConstraints (PPi _ _ c sc) = getConstraints sc+ getConstraints _ = []++ getcapp (PApp _ (PRef _ c) args) + = do ns <- mapM getName args+ return (UConstraint c ns)+ getcapp _ = []++ getName (PExp _ _ (PRef _ n) _) = return n+ getName _ = []+ -- Add implicit Pi bindings for any names in the term which appear in an -- argument position. @@ -697,9 +801,13 @@ then (tm, reverse declimps) else implicitise syn ignore ist (pibind uvars ns tm) where- uvars = using syn+ uvars = map ipair (filter uimplicit (using syn)) pvars = syn_params syn + ipair (UImplicit x y) = (x, y)+ uimplicit (UImplicit _ _) = True+ uimplicit _ = False+ dropAll (x:xs) ys | x `elem` ys = dropAll xs ys | otherwise = x : dropAll xs ys dropAll [] ys = []@@ -742,6 +850,10 @@ = do (decls, ns) <- get let isn = namesIn uvars ist l ++ namesIn uvars ist r put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))+ imps top env (PRewrite _ l r)+ = do (decls, ns) <- get+ let isn = namesIn uvars ist l ++ namesIn uvars ist r+ put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps top env (PTyped l r) = imps top env l imps top env (PPair _ l r)@@ -801,6 +913,9 @@ ai env (PEq fc l r) = let l' = ai env l r' = ai env r in PEq fc l' r'+ ai env (PRewrite fc l r) = let l' = ai env l+ r' = ai env r in+ PRewrite fc l' r' ai env (PTyped l r) = let l' = ai env l r' = ai env r in PTyped l' r'@@ -855,9 +970,9 @@ aiFn :: Bool -> Bool -> IState -> FC -> Name -> [PArg] -> Either Err PTerm aiFn inpat True ist fc f []- = case lookupDef Nothing f (tt_ctxt ist) of+ = case lookupDef f (tt_ctxt ist) of [] -> Right $ PPatvar fc f- alts -> let ialts = lookupCtxt Nothing f (idris_implicits ist) in+ alts -> let ialts = lookupCtxt f (idris_implicits ist) in -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $ if (not (vname f) || tcname f || any constructor alts || any allImp ialts)@@ -877,7 +992,7 @@ | f `elem` primNames = Right $ PApp fc (PRef fc f) as aiFn inpat expat ist fc f as -- This is where namespaces get resolved by adding PAlternative- = case lookupCtxtName Nothing f (idris_implicits ist) of+ = case lookupCtxtName f (idris_implicits ist) of [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as) [] -> if f `elem` idris_metavars ist then Right $ PApp fc (PRef fc f) as@@ -914,6 +1029,42 @@ | n == n' = Just (t, reverse acc ++ gs) find n (g : gs) acc = find n gs (g : acc) +-- replace non-linear occurrences with _+-- ASSUMPTION: This is called before adding 'alternatives' because otherwise+-- it is hard to get right!++stripLinear :: IState -> PTerm -> PTerm+stripLinear i tm = evalState (sl tm) [] where + sl :: PTerm -> State [Name] PTerm+ sl (PRef fc f) + | (_:_) <- lookupTy f (tt_ctxt i)+ = return $ PRef fc f+ | otherwise = do ns <- get+ if (f `elem` ns)+ then return Placeholder+ else do put (f : ns)+ return (PRef fc f)+ sl (PPatvar fc f) + = do ns <- get+ if (f `elem` ns)+ then return Placeholder+ else do put (f : ns)+ return (PPatvar fc f)+ sl (PApp fc fn args) = do fn' <- sl fn+ args' <- mapM slA args+ return $ PApp fc fn' args'+ where slA (PImp p l n t d) = do t' <- sl t+ return $ PImp p l n t' d+ slA (PExp p l t d) = do t' <- sl t+ return $ PExp p l t' d+ slA (PConstraint p l t d) + = do t' <- sl t+ return $ PConstraint p l t' d+ slA (PTacImplicit p l n sc t d) + = do t' <- sl t+ return $ PTacImplicit p l n sc t' d+ sl x = return x+ mkPApp fc a f [] = f mkPApp fc a f as = let rest = drop a as in appRest fc (PApp fc f (take a as)) rest@@ -1011,18 +1162,24 @@ -- match (PRef _ n) (PRef _ n') | n == n' = return [] -- | otherwise = Nothing match (PRef f n) (PApp _ x []) = match (PRef f n) x+ match (PPatvar f n) xr = match (PRef f n) xr+ match xr (PPatvar f n) = match xr (PRef f n) match (PApp _ x []) (PRef f n) = match x (PRef f n) match (PRef _ n) tm@(PRef _ n') | n == n' && not names && - (not (isConName Nothing n (tt_ctxt i)) || tm == Placeholder)+ (not (isConName n (tt_ctxt i)) || tm == Placeholder) = return [(n, tm)] | n == n' = return [] match (PRef _ n) tm - | not names && (not (isConName Nothing n (tt_ctxt i)) || tm == Placeholder)+ | not names && (not (isConName n (tt_ctxt i)) || tm == Placeholder) = return [(n, tm)] match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l' mr <- match' r r' return (ml ++ mr)+ match (PRewrite _ l r) (PRewrite _ l' r') + = do ml <- match' l l'+ mr <- match' r r'+ return (ml ++ mr) match (PTyped l r) (PTyped l' r') = do ml <- match l l' mr <- match r r' return (ml ++ mr)@@ -1104,6 +1261,7 @@ sm xs (PApp f x as) = PApp f (sm xs x) (map (fmap (sm xs)) as) sm xs (PCase f x as) = PCase f (sm xs x) (map (pmap (sm xs)) as) sm xs (PEq f x y) = PEq f (sm xs x) (sm xs y)+ sm xs (PRewrite f x y) = PRewrite f (sm xs x) (sm xs y) sm xs (PTyped x y) = PTyped (sm xs x) (sm xs y) sm xs (PPair f x y) = PPair f (sm xs x) (sm xs y) sm xs (PDPair f x t y) = PDPair f (sm xs x) (sm xs t) (sm xs y)@@ -1119,6 +1277,7 @@ sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as) sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as) sm (PEq f x y) = PEq f (sm x) (sm y)+ sm (PRewrite f x y) = PRewrite f (sm x) (sm y) sm (PTyped x y) = PTyped (sm x) (sm y) sm (PPair f x y) = PPair f (sm x) (sm y) sm (PDPair f x t y) = PDPair f (sm x) (sm t) (sm y)
src/Idris/AbsSyntaxTree.hs view
@@ -10,6 +10,7 @@ import IRTS.Lang import IRTS.CodegenCommon import Util.Pretty+import Util.DynamicLinker import Paths_idris @@ -23,24 +24,44 @@ import Debug.Trace -data IOption = IOption { opt_logLevel :: Int,- opt_typecase :: Bool,+data IOption = IOption { opt_logLevel :: Int,+ opt_typecase :: Bool, opt_typeintype :: Bool,- opt_coverage :: Bool,- opt_showimp :: Bool,+ opt_coverage :: Bool,+ opt_showimp :: Bool, opt_errContext :: Bool,- opt_repl :: Bool,- opt_verbose :: Bool,- opt_target :: Target,- opt_outputTy :: OutputType,- opt_ibcsubdir :: FilePath,+ opt_repl :: Bool,+ opt_verbose :: Bool,+ opt_quiet :: Bool,+ opt_target :: Target,+ opt_outputTy :: OutputType,+ opt_ibcsubdir :: FilePath, opt_importdirs :: [FilePath],- opt_cmdline :: [Opt] -- remember whole command line+ opt_cmdline :: [Opt] -- remember whole command line } deriving (Show, Eq) -defaultOpts = IOption 0 False False True False False True True ViaC Executable "" [] []+defaultOpts = IOption { opt_logLevel = 0+ , opt_typecase = False+ , opt_typeintype = False+ , opt_coverage = True+ , opt_showimp = False+ , opt_errContext = False+ , opt_repl = True+ , opt_verbose = True+ , opt_quiet = False+ , opt_target = ViaC+ , opt_outputTy = Executable+ , opt_ibcsubdir = ""+ , opt_importdirs = []+ , opt_cmdline = []+ } +data LanguageExt = TypeProviders deriving (Show, Eq, Read, Ord)++-- | The output mode in use+data OutputMode = RawOutput | IdeSlave Integer deriving Show+ -- TODO: Add 'module data' to IState, which can be saved out and reloaded quickly (i.e -- without typechecking). -- This will include all the functions and data declarations, plus fixity declarations@@ -58,7 +79,8 @@ idris_dsls :: Ctxt DSL, idris_optimisation :: Ctxt OptInfo, idris_datatypes :: Ctxt TypeInfo,- idris_patdefs :: Ctxt [([Name], Term, Term)], -- not exported+ idris_patdefs :: Ctxt ([([Name], Term, Term)], [PTerm]), -- not exported+ -- ^ list of lhs/rhs, and a list of missing clauses idris_flags :: Ctxt [FnOpt], idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos idris_calledgraph :: Ctxt [Name],@@ -78,19 +100,22 @@ idris_hdrs :: [String], proof_list :: [(Name, [String])], errLine :: Maybe Int,- lastParse :: Maybe Name, + lastParse :: Maybe Name, indent_stack :: [Int], brace_stack :: [Maybe Int], hide_list :: [(Name, Maybe Accessibility)], default_access :: Accessibility, default_total :: Bool, ibc_write :: [IBCWrite],- compiled_so :: Maybe String+ compiled_so :: Maybe String,+ idris_dynamic_libs :: [DynamicLib],+ idris_language_extensions :: [LanguageExt],+ idris_outputmode :: OutputMode } data SizeChange = Smaller | Same | Bigger | Unknown deriving (Show, Eq)-{-! +{-! deriving instance Binary SizeChange !-} @@ -122,6 +147,7 @@ | IBCImport FilePath | IBCObj FilePath | IBCLib String+ | IBCDyLib String | IBCHeader String | IBCAccess Name Accessibility | IBCTotal Name Totality@@ -136,10 +162,11 @@ emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext [] "" defaultOpts 6 [] [] [] [] [] [] [] [] []- [] Nothing Nothing [] [] [] Hidden False [] Nothing+ [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput -- | The monad for the main REPL - reading and processing files and updating -- global state (hence the IO inner monad).+--type Idris = WriterT [Either String (IO ())] (State IState a)) type Idris = StateT IState IO -- Commands in the REPL@@ -160,6 +187,7 @@ | TotCheck Name | Reload | Load FilePath + | ChangeDirectory FilePath | ModImport String | Edit | Compile Target String@@ -180,6 +208,8 @@ | Defn Name | Info Name | Missing Name+ | DynamicLink FilePath+ | ListDynamic | Pattelab PTerm | DebugInfo Name | Search PTerm@@ -190,6 +220,8 @@ data Opt = Filename String | Ver | Usage+ | Quiet+ | Ideslave | ShowLibs | ShowLibdir | ShowIncs@@ -220,6 +252,7 @@ | FOVM String | UseTarget Target | OutputTy OutputType+ | Extension LanguageExt deriving (Show, Eq) -- Parsed declarations@@ -330,12 +363,22 @@ | PSyntax FC Syntax -- ^ Syntax definition | PMutual FC [PDecl' t] -- ^ Mutual block | PDirective (Idris ()) -- ^ Compiler directive. The parser inserts the corresponding action in the Idris monad.+ | PProvider SyntaxInfo FC Name t t -- ^ Type provider. The first t is the type, the second is the term deriving Functor {-! deriving instance Binary PDecl' !-} -data PClause' t = PClause FC Name t [t] t [PDecl' t]+-- | One clause of a top-level definition. Term arguments to constructors are:+--+-- 1. The whole application (missing for PClauseR and PWithR because they're within a "with" clause)+--+-- 2. The list of patterns+--+-- 3. The right-hand side+--+-- 4. The where block (PDecl' t)+data PClause' t = PClause FC Name t [t] t [PDecl' t] -- ^ A normal top-level definition. | PWith FC Name t [t] t [PDecl' t] | PClauseR FC [t] t [PDecl' t] | PWithR FC [t] t [PDecl' t]@@ -371,12 +414,19 @@ declared (PTy _ _ _ _ n t) = [n] declared (PPostulate _ _ _ _ n t) = [n] declared (PClauses _ _ n _) = [] -- not a declaration-declared (PRecord _ _ _ n _ _ c _) = [n, c]+declared (PCAF _ n _) = [n] declared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts where fstt (_, a, _, _) = a+declared (PData _ _ _ _ (PLaterdecl n _)) = [n] declared (PParams _ _ ds) = concatMap declared ds-declared (PMutual _ ds) = concatMap declared ds declared (PNamespace _ ds) = concatMap declared ds+declared (PRecord _ _ _ n _ _ c _) = [n, c]+declared (PClass _ _ _ _ n _ ms) = n : concatMap declared ms+declared (PInstance _ _ _ _ _ _ _ _) = []+declared (PDSL n _) = [n]+declared (PSyntax _ _) = []+declared (PMutual _ ds) = concatMap declared ds+declared (PDirective _) = [] -- get the names declared, not counting nested parameter blocks tldeclared :: PDecl -> [Name]@@ -390,20 +440,27 @@ tldeclared (PParams _ _ ds) = [] tldeclared (PMutual _ ds) = concatMap tldeclared ds tldeclared (PNamespace _ ds) = concatMap tldeclared ds--- declared (PImport _) = [] + defined :: PDecl -> [Name] defined (PFix _ _ _) = [] defined (PTy _ _ _ _ n t) = [] defined (PPostulate _ _ _ _ n t) = [] defined (PClauses _ _ n _) = [n] -- not a declaration-defined (PRecord _ _ _ n _ _ c _) = [n, c]+defined (PCAF _ n _) = [n] defined (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts where fstt (_, a, _, _) = a+defined (PData _ _ _ _ (PLaterdecl n _)) = [] defined (PParams _ _ ds) = concatMap defined ds-defined (PMutual _ ds) = concatMap defined ds defined (PNamespace _ ds) = concatMap defined ds--- declared (PImport _) = []+defined (PRecord _ _ _ n _ _ c _) = [n, c]+defined (PClass _ _ _ _ n _ ms) = n : concatMap defined ms+defined (PInstance _ _ _ _ _ _ _ _) = []+defined (PDSL n _) = [n]+defined (PSyntax _ _) = []+defined (PMutual _ ds) = concatMap defined ds+defined (PDirective _) = []+--defined _ = [] updateN :: [(Name, Name)] -> Name -> Name updateN ns n | Just n' <- lookup n ns = n'@@ -442,6 +499,7 @@ | PRefl FC PTerm | PResolveTC FC | PEq FC PTerm PTerm+ | PRewrite FC PTerm PTerm | PPair FC PTerm PTerm | PDPair FC PTerm PTerm PTerm | PAlternative Bool [PTerm] -- True if only one may work@@ -468,6 +526,7 @@ mpt (PLam n t s) = PLam n (mapPT f t) (mapPT f s) mpt (PPi p n t s) = PPi p n (mapPT f t) (mapPT f s) mpt (PLet n ty v s) = PLet n (mapPT f ty) (mapPT f v) (mapPT f s)+ mpt (PRewrite fc t s) = PRewrite fc (mapPT f t) (mapPT f s) mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as) mpt (PCase fc c os) = PCase fc (mapPT f c) (map (pmap (mapPT f)) os) mpt (PEq fc l r) = PEq fc (mapPT f l) (mapPT f r)@@ -491,7 +550,9 @@ | ProofState | ProofTerm | Undo | Try (PTactic' t) (PTactic' t) | TSeq (PTactic' t) (PTactic' t)- | ReflectTac t -- see Language.Reflection module+ | ApplyTactic t -- see Language.Reflection module+ | Reflect t+ | Fill t | GoalType String (PTactic' t) | Qed | Abandon deriving (Show, Eq, Functor)@@ -516,6 +577,9 @@ size Undo = 1 size (Try l r) = 1 + size l + size r size (TSeq l r) = 1 + size l + size r+ size (ApplyTactic t) = 1 + size t+ size (Reflect t) = 1 + size t+ size (Fill t) = 1 + size t size Qed = 1 size Abandon = 1 @@ -659,7 +723,14 @@ Nothing where f = FC "(builtin)" 0 -data SyntaxInfo = Syn { using :: [(Name, PTerm)],+data Using = UImplicit Name PTerm+ | UConstraint Name [Name]+ deriving (Show, Eq)+{-!+deriving instance Binary Using+!-}++data SyntaxInfo = Syn { using :: [Using], syn_params :: [(Name, PTerm)], syn_namespace :: [String], no_imp :: [Name],@@ -844,10 +915,10 @@ bracket p 1 $ prettySe 1 f <+> if impl then- foldl fS empty as+ foldl' fS empty as -- foldr (<+>) empty $ map prettyArgS as else- foldl fSe empty args+ foldl' fSe empty args -- foldr (<+>) empty $ map prettyArgSe args where fS l r =@@ -878,6 +949,12 @@ prettySe 10 l <+> text "=" $$ nest nestingSize (prettySe 10 r) else prettySe 10 l <+> text "=" <+> prettySe 10 r+ prettySe p (PRewrite _ l r) =+ bracket p 2 $+ if size r > breakingSize then+ text "rewrite" <+> prettySe 10 l <+> text "in" $$ nest nestingSize (prettySe 10 r)+ else+ text "rewrite" <+> prettySe 10 l <+> text "in" <+> prettySe 10 r prettySe p (PTyped l r) = lparen <> prettySe 10 l <+> colon <+> prettySe 10 r <> rparen prettySe p (PPair _ l r) =@@ -930,7 +1007,7 @@ showImp :: Bool -> PTerm -> String showImp impl tm = se 10 tm where se p (PQuote r) = "![" ++ show r ++ "]"- se p (PPatvar fc n) = show n+ se p (PPatvar fc n) = if impl then show n ++ "[p]" else show n se p (PInferRef fc n) = "!" ++ show n -- ++ "[" ++ show fc ++ "]" se p (PRef fc n) = if impl then show n -- ++ "[" ++ show fc ++ "]" else showbasic n@@ -965,6 +1042,9 @@ = bracket p 2 $ se 10 ty ++ " => " ++ se 10 sc se p (PPi (TacImp _ _ s _) n ty sc) = bracket p 2 $ "{tacimp " ++ show n ++ " : " ++ se 10 ty ++ "} -> " ++ se 10 sc+ se p e+ | Just str <- slist p e = str+ | Just num <- snat p e = show num se p (PApp _ (PRef _ f) []) | not impl = show f se p (PApp _ (PRef _ op@(UN (f:_))) args)@@ -985,6 +1065,7 @@ se p (PTrue _) = "()" se p (PFalse _) = "_|_" se p (PEq _ l r) = bracket p 2 $ se 10 l ++ " = " ++ se 10 r+ se p (PRewrite _ l r) = bracket p 2 $ "rewrite " ++ se 10 l ++ " in " ++ se 10 r se p (PTyped l r) = "(" ++ se 10 l ++ " : " ++ se 10 r ++ ")" se p (PPair _ l r) = "(" ++ se 10 l ++ ", " ++ se 10 r ++ ")" se p (PDPair _ l t r) = "(" ++ se 10 l ++ " ** " ++ se 10 r ++ ")"@@ -1002,6 +1083,37 @@ se p (PCoerced t) = se p t -- se p x = "Not implemented" + slist' p (PApp _ (PRef _ nil) _)+ | nsroot nil == UN "Nil" = Just []+ slist' p (PApp _ (PRef _ cons) args)+ | nsroot cons == UN "::",+ (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,+ all isImp imps,+ Just tl' <- slist' p tl+ = Just (hd:tl')+ where+ isImp (PImp {}) = True+ isImp _ = False+ slist' _ _ = Nothing++ slist p e | Just es <- slist' p e = Just $+ case es of [] -> "[]"+ [x] -> "[" ++ se p x ++ "]"+ xs -> "[" ++ intercalate "," (map (se p) xs) ++ "]"+ slist _ _ = Nothing++ -- since Prelude is always imported, S & O are unqualified iff they're the+ -- Nat ones.+ snat p (PRef _ o)+ | show o == (natns++"O") || show o == "O" = Just 0+ snat p (PApp _ s [PExp {getTm=n}])+ | show s == (natns++"S") || show s == "S",+ Just n' <- snat p n+ = Just $ 1 + n'+ snat _ _ = Nothing++ natns = "Prelude.Nat."+ sArg (PImp _ _ n tm _) = siArg (n, tm) sArg (PExp _ _ tm _) = seArg tm sArg (PConstraint _ _ tm _) = scArg tm@@ -1030,6 +1142,7 @@ size (PRefl fc _) = 1 size (PResolveTC fc) = 1 size (PEq fc left right) = 1 + size left + size right+ size (PRewrite fc left right) = 1 + size left + size right size (PPair fc left right) = 1 + size left + size right size (PDPair fs left ty right) = 1 + size left + size ty + size right size (PAlternative a alts) = 1 + size alts@@ -1062,6 +1175,7 @@ ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc ni env (PHidden tm) = ni env tm ni env (PEq _ l r) = ni env l ++ ni env r+ ni env (PRewrite _ l r) = ni env l ++ ni env r ni env (PTyped l r) = ni env l ++ ni env r ni env (PPair _ l r) = ni env l ++ ni env r ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r@@ -1076,7 +1190,7 @@ where ni env (PRef _ n) | not (n `elem` env) - = case lookupTy Nothing n (tt_ctxt ist) of+ = case lookupTy n (tt_ctxt ist) of [] -> [n] _ -> if n `elem` (map fst uvars) then [n] else [] ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)@@ -1084,6 +1198,7 @@ ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc ni env (PEq _ l r) = ni env l ++ ni env r+ ni env (PRewrite _ l r) = ni env l ++ ni env r ni env (PTyped l r) = ni env l ++ ni env r ni env (PPair _ l r) = ni env l ++ ni env r ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r@@ -1099,7 +1214,7 @@ where ni env (PRef _ n) | n `elem` vars && not (n `elem` env) - = case lookupTy Nothing n (tt_ctxt ist) of+ = case lookupTy n (tt_ctxt ist) of [] -> [n] _ -> [] ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)@@ -1107,6 +1222,7 @@ ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc ni env (PEq _ l r) = ni env l ++ ni env r+ ni env (PRewrite _ l r) = ni env l ++ ni env r ni env (PTyped l r) = ni env l ++ ni env r ni env (PPair _ l r) = ni env l ++ ni env r ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r
src/Idris/Completion.hs view
@@ -3,8 +3,10 @@ import Core.Evaluate (ctxtAlist) import Core.TT+import Core.CoreParser (opChars) import Idris.AbsSyntaxTree+import Idris.Help import Control.Monad.State.Strict @@ -13,40 +15,12 @@ import System.Console.Haskeline --- TODO: add specific classes of identifiers to complete, fx metavariables--- | A specification of the arguments that REPL commands can take-data CmdArg = ExprArg -- ^ The command takes an expression- | NameArg -- ^ The command takes a name- | FileArg -- ^ The command takes a file- | ModuleArg -- ^ The command takes a module name- | OptionArg -- ^ The command takes an option --- | Information about how to complete the various commands-cmdArgs :: [(String, CmdArg)]-cmdArgs = [ (":t", ExprArg)- , (":miss", NameArg)- , (":missing", NameArg)- , (":i", NameArg)- , (":info", NameArg)- , (":total", NameArg)- , (":l", FileArg)- , (":load", FileArg)- , (":m", ModuleArg) -- NOTE: Argumentless form is a different command- , (":p", NameArg)- , (":prove", NameArg)- , (":a", NameArg)- , (":addproof", NameArg)- , (":rmproof", NameArg)- , (":showproof", NameArg)- , (":c", FileArg)- , (":compile", FileArg)- , (":js", FileArg)- , (":javascript", FileArg)- , (":set", OptionArg)- , (":unset", OptionArg)- ]-commands = map fst cmdArgs+fst3 :: (a, b, c) -> a+fst3 (a, b, c) = a +commands = concatMap fst3 help+ -- | A specification of the arguments that tactics can take data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n | ExprTArg@@ -61,7 +35,9 @@ , ("let", Nothing) -- FIXME syntax for let , ("focus", Just ExprTArg) , ("exact", Just ExprTArg)+ , ("applyTactic", Just ExprTArg) , ("reflect", Just ExprTArg)+ , ("fill", Just ExprTArg) , ("try", Just AltsTArg) ] ++ map (\x -> (x, Nothing)) [ "intro", "intros", "compute", "trivial", "solve", "attack",@@ -80,12 +56,20 @@ -- FIXME: Respect module imports -- | Get the user-visible names from the current interpreter state.-names :: Idris[String]+names :: Idris [String] names = do i <- get let ctxt = tt_ctxt i- return $ nub $ mapMaybe (nameString . fst) $ ctxtAlist ctxt+ return . nub $+ mapMaybe (nameString . fst) (ctxtAlist ctxt) +++ -- Explicitly add primitive types, as these are special-cased in the parser+ ["Int", "Integer", "Float", "Char", "String", "Type",+ "Ptr", "Bits8", "Bits16", "Bits32", "Bits64"] +metavars :: Idris [String]+metavars = do i <- get+ return . map (show . nsroot) $ idris_metavars i \\ primDefs + modules :: Idris [String] modules = do i <- get return $ map show $ imported i@@ -97,15 +81,20 @@ then [simpleCompletion n] else map simpleCompletion prefixMatches where prefixMatches = filter (isPrefixOf n) ns- uniqueExists = n `elem` prefixMatches+ uniqueExists = [n] == prefixMatches completeName :: [String] -> String -> Idris [Completion] completeName extra n = do ns <- names return $ completeWith (extra ++ ns) n completeExpr :: [String] -> CompletionFunc Idris-completeExpr extra = completeWord Nothing " \t" (completeName extra)+completeExpr extra = completeWord Nothing (" \t(){}:" ++ opChars) (completeName extra) +completeMetaVar :: CompletionFunc Idris+completeMetaVar = completeWord Nothing (" \t(){}:" ++ opChars) completeM+ where completeM m = do mvs <- metavars+ return $ completeWith mvs m+ completeOption :: CompletionFunc Idris completeOption = completeWord Nothing " \t" completeOpt where completeOpt = return . (completeWith ["errorcontext", "showimplicits"])@@ -113,14 +102,22 @@ isWhitespace :: Char -> Bool isWhitespace = (flip elem) " \t\n" +lookupInHelp :: String -> Maybe CmdArg+lookupInHelp cmd = lookupInHelp' cmd help+ where lookupInHelp' cmd ((cmds, arg, _):xs) | elem cmd cmds = Just arg+ | otherwise = lookupInHelp' cmd xs+ lookupInHelp' cmd [] = Nothing+ -- | Get the completion function for a particular command completeCmd :: String -> CompletionFunc Idris-completeCmd cmd (prev, next) = fromMaybe completeCmdName $ fmap completeArg $ lookup cmd cmdArgs+completeCmd cmd (prev, next) = fromMaybe completeCmdName $ fmap completeArg $ lookupInHelp cmd where completeArg FileArg = completeFilename (prev, next) completeArg NameArg = completeExpr [] (prev, next) -- FIXME only complete one name completeArg OptionArg = completeOption (prev, next) completeArg ModuleArg = noCompletion (prev, next) -- FIXME do later completeArg ExprArg = completeExpr [] (prev, next)+ completeArg MetaVarArg = completeMetaVar (prev, next) -- FIXME only complete one name+ completeArg NoArg = noCompletion (prev, next) completeCmdName = return $ ("", completeWith commands cmd) -- | Complete REPL commands and defined identifiers
src/Idris/Coverage.hs view
@@ -17,28 +17,13 @@ import Control.Monad.State --- Generate the LHSes which are missing from a case tree--- Eliminate the ones which cannot be well typed--genMissing :: Name -> [Name] -> SC -> Idris [PTerm] -genMissing fn args sc - = do sc' <- expandTree sc- logLvl 5 $ "Checking missing cases for " ++ - show fn ++ "\n" ++ (show sc')- (got, missing) <- gm fn (map (\x -> P Bound x Erased) args) sc'- return $ filter (\x -> not (x `elem` got)) missing---- Make a term to feed to the pattern matcher from a LHS declared impossible--- (we can't type check it, but we need the case analysis to check for --- covering...)- mkPatTm :: PTerm -> Idris Term mkPatTm t = do i <- getIState let timp = addImpl' True [] [] i t evalStateT (toTT timp) 0 where toTT (PRef _ n) = do i <- lift getIState- case lookupDef Nothing n (tt_ctxt i) of+ case lookupDef n (tt_ctxt i) of [TyDecl nt _] -> return $ P nt n Erased _ -> return $ P Ref n Erased toTT (PApp _ t args) = do t' <- toTT t@@ -48,101 +33,6 @@ put (v + 1) return (P Bound (MN v "imp") Erased) -mkPTerm :: Name -> [TT Name] -> Idris PTerm-mkPTerm f args = do i <- getIState- let fapp = mkApp (P Bound f Erased) (map eraseName args)- return $ delab i fapp- where eraseName (App f a) = App (eraseName f) (eraseName a)- eraseName (P _ (MN _ _) _) = Erased- eraseName t = t--gm :: Name -> [TT Name] -> SC -> Idris ([PTerm], [PTerm])-gm fn args (Case n alts) = do m <- mapM (gmAlt fn args n) alts- let (got, missing) = unzip m- return (concat got, concat missing)-gm fn args (STerm tm) = do logLvl 3 ("Covered: " ++ show args)- t <- mkPTerm fn args- return ([t], [])-gm fn args ImpossibleCase = do logLvl 3 ("Impossible: " ++ show args)- t <- mkPTerm fn args- return ([], [])-gm fn args (UnmatchedCase _) = do logLvl 3 ("Missing: " ++ show args)- t <- mkPTerm fn args- return ([], [t])--gmAlt fn args n (ConCase cn t cargs sc)- = do let args' = map (subst n (mkApp (P Bound cn Erased)- (map (\x -> P Bound x Erased) cargs))) - args- gm fn args' sc-gmAlt fn args n (ConstCase c sc)- = do let args' = map (subst n (Constant c)) args- gm fn args' sc-gmAlt fn args n (DefaultCase sc)- = do gm fn args sc--getDefault (DefaultCase sc : _) = sc-getDefault (_ : cs) = getDefault cs-getDefault [] = UnmatchedCase ""--dropDefault (DefaultCase sc : rest) = dropDefault rest-dropDefault (c : cs) = c : dropDefault cs-dropDefault [] = [] --expandTree :: SC -> Idris SC-expandTree (Case n alts) = do i <- getIState- as <- expandAlts i (dropDefault alts) - (getDefault alts)- alts' <- mapM expandTreeA as- return (Case n alts')- where expandTreeA (ConCase n i ns sc) = do sc' <- expandTree sc- return (ConCase n i ns sc')- expandTreeA (ConstCase i sc) = do sc' <- expandTree sc- return (ConstCase i sc')- expandTreeA (DefaultCase sc) = do sc' <- expandTree sc- return (DefaultCase sc')-expandTree t = return t--expandAlts :: IState -> [CaseAlt] -> SC -> Idris [CaseAlt]-expandAlts i all@(ConstCase c _ : alts) def- = return $ all ++ [DefaultCase def]-expandAlts i all@(ConCase n _ _ _ : alts) def- | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef Nothing n (tt_ctxt i)- = do let tyn = getTy n (tt_ctxt i)- case lookupCtxt Nothing tyn (idris_datatypes i) of- (TI ns _ _: _) -> do let ps = map mkPat ns- return $ addAlts ps (altsFor all) all- _ -> return all- where- altsFor [] = []- altsFor (ConCase n _ _ _ : alts) = n : altsFor alts- altsFor (_ : alts) = altsFor alts-- addAlts [] got alts = alts- addAlts ((n, arity) : ps) got alts- | n `elem` got = addAlts ps got alts- | otherwise = addAlts ps got (alts ++ - [ConCase n (-1) (argList arity) def])-- argList i = take i (map (\x -> (MN x "ign")) [0..])-- getTy n ctxt - = case lookupTy Nothing n ctxt of- (t : _) -> case unApply (getRetTy t) of- (P _ tyn _, _) -> tyn- x -> error $ "Can't happen getTy 1 " ++ show (n, x)- _ -> error "Can't happen getTy 2"-- mkPat x = case lookupCtxt Nothing x (idris_implicits i) of- (pargs : _)- -> (x, length pargs) - _ -> error "Can't happen - genAll"-expandAlts i alts def = return alts - ----- OLD STUFF: probably broken...- -- Given a list of LHSs, generate a extra clauses which cover the remaining -- cases. The ones which haven't been provided are marked 'absurd' so that the -- checker will make sure they can't happen.@@ -160,7 +50,7 @@ logLvl 10 $ show argss ++ "\n" ++ show all_args logLvl 10 $ "Original: \n" ++ showSep "\n" (map (\t -> showImp True (delab' i t True)) xs)- let parg = case lookupCtxt Nothing n (idris_implicits i) of+ let parg = case lookupCtxt n (idris_implicits i) of (p : _) -> p _ -> repeat (pexp Placeholder) let tryclauses = mkClauses parg all_args@@ -217,8 +107,8 @@ [] -> [Placeholder] xs -> nub xs where - conForm (PApp _ (PRef fc n) _) = isConName Nothing n (tt_ctxt i)- conForm (PRef fc n) = isConName Nothing n (tt_ctxt i)+ conForm (PApp _ (PRef fc n) _) = isConName n (tt_ctxt i)+ conForm (PRef fc n) = isConName n (tt_ctxt i) conForm _ = False otherPats :: PTerm -> [PTerm]@@ -227,22 +117,22 @@ otherPats arg = return Placeholder ops fc n xs o- | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef Nothing n (tt_ctxt i)+ | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef n (tt_ctxt i) = do xs' <- mapM otherPats (map getTm xs) let p = PApp fc (PRef fc n) (zipWith upd xs' xs) let tyn = getTy n (tt_ctxt i)- case lookupCtxt Nothing tyn (idris_datatypes i) of+ case lookupCtxt tyn (idris_datatypes i) of (TI ns _ _ : _) -> p : map (mkPat fc) (ns \\ [n]) _ -> [p] ops fc n arg o = return Placeholder - getTy n ctxt = case lookupTy Nothing n ctxt of+ getTy n ctxt = case lookupTy n ctxt of (t : _) -> case unApply (getRetTy t) of (P _ tyn _, _) -> tyn x -> error $ "Can't happen getTy 1 " ++ show (n, x) _ -> error "Can't happen getTy 2" - mkPat fc x = case lookupCtxt Nothing x (idris_implicits i) of+ mkPat fc x = case lookupCtxt x (idris_implicits i) of (pargs : _) -> PApp fc (PRef fc x) (map (upd Placeholder) pargs) _ -> error "Can't happen - genAll"@@ -272,50 +162,62 @@ = n /= n' && posArg sc posArg t = True --- Totality checking - check for structural recursion --- (no mutual definitions yet)--data LexOrder = LexXX | LexEQ | LexLT- deriving (Show, Eq, Ord)- calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality-calcProd i fc n pats = do patsprod <- mapM prodRec pats- if (and patsprod) - then return Productive- else return (Partial NotProductive)+calcProd i fc topn pats + = cp topn pats [] where -- every application of n must be in an argument of a coinductive - -- constructor+ -- constructor, in every function reachable from here in the+ -- call graph.+ cp n pats done = do patsprod <- mapM (prodRec n done) pats+ if (and patsprod) + then return Productive+ else return (Partial NotProductive) - prodRec :: ([Name], Term, Term) -> Idris Bool- prodRec (_, _, tm) = prod False tm + prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool+ prodRec n done _ | n `elem` done = return True+ prodRec n done (_, _, tm) = prod n done False tm - prod ok ap@(App _ _)- | (P _ (UN "lazy") _, [_, arg]) <- unApply ap = prod ok arg- | (P _ f ty, args) <- unApply ap- = let co = cotype ty in- if f == n - then do argsprod <- mapM (prod co) args- return (and (ok : argsprod) )- else do argsprod <- mapM (prod co) args- return (and argsprod)- prod ok (App f a) = liftM2 (&&) (prod False f) (prod False a)- prod ok (Bind _ (Let t v) sc) = liftM2 (&&) (prod False v) (prod False v)- prod ok (Bind _ b sc) = prod ok sc- prod ok t = return True - - cotype ty + prod :: Name -> [Name] -> Bool -> Term -> Idris Bool+ prod n done ok ap@(App _ _)+ | (P _ (UN "lazy") _, [_, arg]) <- unApply ap = prod n done ok arg+ | (P nt f _, args) <- unApply ap+ = do recOK <- checkProdRec (n:done) f+ let ctxt = tt_ctxt i+ let [ty] = lookupTy f ctxt -- must exist!+ let co = cotype nt f ty in+ if (not recOK) then return False else+ if f == topn + then do argsprod <- mapM (prod n done co) args+ return (and (ok : argsprod) )+ else do argsprod <- mapM (prod n done co) args+ return (and argsprod)+ prod n done ok (App f a) = liftM2 (&&) (prod n done False f) + (prod n done False a)+ prod n done ok (Bind _ (Let t v) sc) + = liftM2 (&&) (prod n done False v) (prod n done False v)+ prod n done ok (Bind _ b sc) = prod n done ok sc+ prod n done ok t = return True + + checkProdRec :: [Name] -> Name -> Idris Bool+ checkProdRec done f + = case lookupCtxt f (idris_patdefs i) of+ [(def, _)] -> do ok <- mapM (prodRec f done) def+ return (and ok)+ _ -> return True -- defined elsewhere, can't call topn++ cotype (DCon _ _) n ty | (P _ t _, _) <- unApply (getRetTy ty)- = case lookupCtxt Nothing t (idris_datatypes i) of+ = case lookupCtxt t (idris_datatypes i) of [TI _ True _] -> True _ -> False- | otherwise = False+ cotype nt n ty = False calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality calcTotality path fc n pats = do i <- getIState- let opts = case lookupCtxt Nothing n (idris_flags i) of+ let opts = case lookupCtxt n (idris_flags i) of [fs] -> fs _ -> [] case mapMaybe (checkLHS i) (map (\ (_, l, r) -> l) pats) of@@ -339,12 +241,12 @@ updateContext (simplifyCasedef n) ctxt <- getContext i <- getIState- let opts = case lookupCtxt Nothing n (idris_flags i) of+ let opts = case lookupCtxt n (idris_flags i) of [fs] -> fs _ -> [] t' <- case t of Unchecked -> - case lookupDef Nothing n ctxt of+ case lookupDef n ctxt of [CaseOp _ _ _ _ pats _ _ _ _] -> do t' <- if AssertTotal `elem` opts then return $ Total []@@ -378,7 +280,7 @@ warnPartial n t = do i <- getIState- case lookupDef Nothing n (tt_ctxt i) of+ case lookupDef n (tt_ctxt i) of [x] -> do iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t -- ++ "\n" ++ show x@@ -407,8 +309,8 @@ buildSCG :: (FC, Name) -> Idris () buildSCG (_, n) = do ist <- getIState- case lookupCtxt Nothing n (idris_callgraph ist) of- [cg] -> case lookupDef Nothing n (tt_ctxt ist) of+ case lookupCtxt n (idris_callgraph ist) of+ [cg] -> case lookupDef n (tt_ctxt ist) of [CaseOp _ _ _ _ _ args sc _ _] -> do logLvl 3 $ "Building SCG for " ++ show n ++ " from\n" ++ show sc@@ -442,17 +344,22 @@ -- how the arguments relate - either Smaller or Unknown argRels :: Name -> [(Name, SizeChange)] argRels n = let ctxt = tt_ctxt ist- [ty] = lookupTy Nothing n ctxt -- must exist!+ [ty] = lookupTy n ctxt -- must exist! P _ nty _ = fst (unApply (getRetTy ty))+ co = case lookupCtxt nty (idris_datatypes ist) of+ [TI _ x _] -> x+ _ -> False args = map snd (getArgTys ty) in- map (getRel nty) (map (fst . unApply . getRetTy) args)+ map (getRel co nty) (map (fst . unApply . getRetTy) args) where- getRel ty (P _ n' _) | n' == ty = (n, Smaller)- getRel ty t = (n, Unknown)+ getRel True _ _ = (n, Unknown) -- coinductive+ getRel _ ty (P _ n' _) | n' == ty = (n, Smaller)+ getRel _ ty t = (n, Unknown) scgAlt x vars szs (ConCase n _ args sc) -- all args smaller than top variable of x in sc- -- (as long as they are in the same type family)+ -- (as long as they are in the same type family, and it's+ -- not coinductive) | Just tvar <- lookup x vars = let arel = argRels n szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel @@ -503,7 +410,7 @@ checkSizeChange :: Name -> Idris Totality checkSizeChange n = do ist <- getIState- case lookupCtxt Nothing n (idris_callgraph ist) of+ case lookupCtxt n (idris_callgraph ist) of [cg] -> do let ms = mkMultiPaths ist [] (scg cg) logLvl 5 ("Multipath for " ++ show n ++ ":\n" ++ "from " ++ show (scg cg) ++ "\n" ++@@ -530,7 +437,7 @@ where extend (nextf, args) | (nextf, args) `elem` path = [ reverse ((nextf, args) : path) ] | [Unchecked] <- lookupTotal nextf (tt_ctxt ist) - = case lookupCtxt Nothing nextf (idris_callgraph ist) of+ = case lookupCtxt nextf (idris_callgraph ist) of [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg) _ -> [ reverse ((nextf, args) : path) ] | otherwise = [ reverse ((nextf, args) : path) ]@@ -538,7 +445,7 @@ -- do (nextf, args) <- cg -- if ((nextf, args) `elem` path) -- then return (reverse ((nextf, args) : path))--- else case lookupCtxt Nothing nextf (idris_callgraph ist) of+-- else case lookupCtxt nextf (idris_callgraph ist) of -- [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg) -- _ -> return (reverse ((nextf, args) : path)) @@ -562,15 +469,15 @@ -- = Partial BelieveMe -- if we get to a constructor, it's fine as long as it's strictly positive tryPath desc path ((f, _) :es) arg- | [TyDecl (DCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist)+ | [TyDecl (DCon _ _) _] <- lookupDef f (tt_ctxt ist) = case lookupTotal f (tt_ctxt ist) of [Total _] -> Unchecked -- okay so far [Partial _] -> Partial (Other [f]) x -> error (show x)- | [TyDecl (TCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist)+ | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist) = Total []- tryPath desc path (e@(f, []) : es) arg- | e `elem` es = Partial (Mutual [f])+ tryPath desc path (e@(f, args) : es) arg+ | e `elem` es && allNothing args = Partial (Mutual [f]) tryPath desc path (e@(f, nextargs) : es) arg | Just d <- lookup e path = if desc > 0 @@ -587,7 +494,7 @@ -- rest definitely terminates without -- any cycles with route so far, -- then we might yet be total- case collapse (map (tryPath (-10000) ((e, desc):path) es)+ case collapse (map (tryPath (-10000) ((e, 0):path) es) [0..length nextargs - 1]) of Total _ -> return Unchecked x -> return x@@ -606,6 +513,8 @@ | [Total a] <- lookupTotal f (tt_ctxt ist) = Total a | [Partial _] <- lookupTotal f (tt_ctxt ist) = Partial (Other [f]) | otherwise = Unchecked++allNothing xs = null (collapseNothing (zip xs [0..])) collapseNothing ((Nothing, _) : xs) = filter (\ (x, _) -> case x of
src/Idris/DataOpts.hs view
@@ -17,7 +17,7 @@ forceArgs :: Name -> Type -> Idris () forceArgs n t = do i <- getIState let fargs = force i 0 t- copt <- case lookupCtxt Nothing n (idris_optimisation i) of+ copt <- case lookupCtxt n (idris_optimisation i) of [] -> return $ Optimise False [] [] (op:_) -> return op let opts = addDef n (copt { forceable = fargs }) (idris_optimisation i)@@ -38,7 +38,7 @@ collapsibleIn i t | (P _ tn _, _) <- unApply t- = case lookupCtxt Nothing tn (idris_optimisation i) of+ = case lookupCtxt tn (idris_optimisation i) of [oi] -> collapsible oi _ -> False | otherwise = False@@ -68,7 +68,7 @@ setCollapsible n = do i <- getIState iLOG $ show n ++ " collapsible"- case lookupCtxt Nothing n (idris_optimisation i) of+ case lookupCtxt n (idris_optimisation i) of (oi:_) -> do let oi' = oi { collapsible = True } let opts = addDef n oi' (idris_optimisation i) putIState (i { idris_optimisation = opts })@@ -79,15 +79,15 @@ forceRec :: IState -> (Name, [Type]) -> Idris Bool forceRec i (n, ts)- = case lookupCtxt Nothing n (idris_optimisation i) of+ = case lookupCtxt n (idris_optimisation i) of (oi:_) -> checkFR (forceable oi) 0 ts _ -> return False checkFR fs i [] = return True checkFR fs i (_ : xs) | i `elem` fs = checkFR fs (i + 1) xs checkFR fs i (t : xs) -- must be recursive or type is not collapsible- = do let rt = getRetTy t- if (ty `elem` freeNames rt) + = do let (rtf, rta) = unApply $ getRetTy t+ if (ty `elem` freeNames rtf) then checkFR fs (i+1) xs else return False @@ -161,7 +161,7 @@ | (Var n, args) <- raw_unapply t -- MAGIC HERE = do args' <- mapM applyOpts args i <- getIState- case lookupCtxt Nothing n (idris_optimisation i) of+ case lookupCtxt n (idris_optimisation i) of (oi:_) -> return $ applyDataOpt oi n args' _ -> return (raw_apply (Var n) args') | otherwise = do f' <- applyOpts f@@ -202,14 +202,14 @@ instance Optimisable (TT Name) where applyOpts c@(P (DCon t arity) n _) = do i <- getIState- case lookupCtxt Nothing n (idris_optimisation i) of+ case lookupCtxt n (idris_optimisation i) of (oi:_) -> return $ applyDataOptRT oi n t arity [] _ -> return c applyOpts t@(App f a) | (c@(P (DCon t arity) n _), args) <- unApply t -- MAGIC HERE = do args' <- mapM applyOpts args i <- getIState- case lookupCtxt Nothing n (idris_optimisation i) of+ case lookupCtxt n (idris_optimisation i) of (oi:_) -> do return $ applyDataOptRT oi n t arity args' _ -> return (mkApp c args') | otherwise = do f' <- applyOpts f@@ -224,7 +224,7 @@ stripCollapsed (Bind n (PVar x) t) | (P _ ty _, _) <- unApply x = do i <- getIState- case lookupCtxt Nothing ty (idris_optimisation i) of+ case lookupCtxt ty (idris_optimisation i) of [oi] -> if collapsible oi then do t' <- stripCollapsed t return (Bind n (PVar x) (instantiate Erased t'))
src/Idris/Delaborate.hs view
@@ -7,6 +7,7 @@ import Idris.AbsSyntax import Core.TT+import Core.Evaluate import Debug.Trace @@ -15,54 +16,75 @@ delab :: IState -> Term -> PTerm delab i tm = delab' i tm False +delabTy :: IState -> Name -> PTerm+delabTy i n + = case lookupTy n (tt_ctxt i) of+ (ty:_) -> case lookupCtxt n (idris_implicits i) of+ (imps:_) -> delabTy' i imps ty False+ _ -> delabTy' i [] ty False+ delab' :: IState -> Term -> Bool -> PTerm-delab' ist tm fullname = de [] tm+delab' i t f = delabTy' i [] t f++delabTy' :: IState -> [PArg] -- ^ implicit arguments to type, if any+ -> Term -> Bool -> PTerm+delabTy' ist imps tm fullname = de [] imps tm where un = FC "(val)" 0 - de env (App f a) = deFn env f [a]- de env (V i) | i < length env = PRef un (snd (env!!i))- | otherwise = PRef un (UN ("v" ++ show i ++ ""))- de env (P _ n _) | n == unitTy = PTrue un- | n == unitCon = PTrue un- | n == falseTy = PFalse un- | Just n' <- lookup n env = PRef un n'- | otherwise = PRef un (dens n)- de env (Bind n (Lam ty) sc) = PLam n (de env ty) (de ((n,n):env) sc)- de env (Bind n (Pi ty) sc) = PPi expl n (de env ty) (de ((n,n):env) sc)- de env (Bind n (Let ty val) sc) - = PLet n (de env ty) (de env val) (de ((n,n):env) sc)- de env (Bind n (Hole ty) sc) = de ((n, UN "[__]"):env) sc- de env (Bind n (Guess ty val) sc) = de ((n, UN "[__]"):env) sc- de env (Bind n _ sc) = de ((n,n):env) sc- de env (Constant i) = PConstant i- de env Erased = Placeholder- de env Impossible = Placeholder- de env (TType i) = PType + de env _ (App f a) = deFn env f [a]+ de env _ (V i) | i < length env = PRef un (snd (env!!i))+ | otherwise = PRef un (UN ("v" ++ show i ++ ""))+ de env _ (P _ n _) | n == unitTy = PTrue un+ | n == unitCon = PTrue un+ | n == falseTy = PFalse un+ | Just n' <- lookup n env = PRef un n'+ | otherwise = PRef un (dens n)+ de env _ (Bind n (Lam ty) sc) + = PLam n (de env [] ty) (de ((n,n):env) [] sc)+ de env (PImp _ _ _ _ _:is) (Bind n (Pi ty) sc) + = PPi impl n (de env [] ty) (de ((n,n):env) is sc)+ de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc) + = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)+ de env (PTacImplicit _ _ _ tac _ _:is) (Bind n (Pi ty) sc) + = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)+ de env _ (Bind n (Pi ty) sc) + = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)+ de env _ (Bind n (Let ty val) sc) + = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)+ de env _ (Bind n (Hole ty) sc) = de ((n, UN "[__]"):env) [] sc+ de env _ (Bind n (Guess ty val) sc) = de ((n, UN "[__]"):env) [] sc+ de env _ (Bind n _ sc) = de ((n,n):env) [] sc+ de env _ (Constant i) = PConstant i+ de env _ Erased = Placeholder+ de env _ Impossible = Placeholder+ de env _ (TType i) = PType dens x | fullname = x- dens ns@(NS n _) = case lookupCtxt Nothing n (idris_implicits ist) of+ dens ns@(NS n _) = case lookupCtxt n (idris_implicits ist) of [_] -> n -- just one thing _ -> ns dens n = n deFn env (App f a) args = deFn env f (a:args)- deFn env (P _ n _) [l,r] | n == pairTy = PPair un (de env l) (de env r)- | n == eqCon = PRefl un (de env r)- | n == UN "lazy" = de env r+ deFn env (P _ n _) [l,r] + | n == pairTy = PPair un (de env [] l) (de env [] r)+ | n == eqCon = PRefl un (de env [] r)+ | n == UN "lazy" = de env [] r deFn env (P _ n _) [ty, Bind x (Lam _) r]- | n == UN "Exists" - = PDPair un (PRef un x) (de env ty)- (de ((x,x):env) (instantiate (P Bound x ty) r))- deFn env (P _ n _) [_,_,l,r] | n == pairCon = PPair un (de env l) (de env r)- | n == eqTy = PEq un (de env l) (de env r)- | n == UN "Ex_intro" = PDPair un (de env l) Placeholder- (de env r)- deFn env (P _ n _) args = mkPApp (dens n) (map (de env) args)- deFn env f args = PApp un (de env f) (map pexp (map (de env) args))+ | n == UN "Exists" + = PDPair un (PRef un x) (de env [] ty)+ (de ((x,x):env) [] (instantiate (P Bound x ty) r))+ deFn env (P _ n _) [_,_,l,r] + | n == pairCon = PPair un (de env [] l) (de env [] r)+ | n == eqTy = PEq un (de env [] l) (de env [] r)+ | n == UN "Ex_intro" = PDPair un (de env [] l) Placeholder+ (de env [] r)+ deFn env (P _ n _) args = mkPApp (dens n) (map (de env []) args)+ deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args)) mkPApp n args - | [imps] <- lookupCtxt Nothing n (idris_implicits ist)+ | [imps] <- lookupCtxt n (idris_implicits ist) = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args) | otherwise = PApp un (PRef un n) (map pexp args) @@ -90,6 +112,13 @@ "Can't convert " ++ showImp imps (delab i x) ++ " with " ++ showImp imps (delab i y) ++ if (opt_errContext (idris_options i)) then showSc i env else ""+pshow i (NonFunctionType f ty)+ = let imps = opt_showimp (idris_options i) in+ showImp imps (delab i f) ++ " does not have a function type ("+ ++ showImp imps (delab i ty) ++ ")"+pshow i (CantIntroduce ty)+ = let imps = opt_showimp (idris_options i) in+ "Can't use lambda here: type is " ++ showImp imps (delab i ty) pshow i (InfiniteUnify x tm env) = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++ " would lead to infinite value" ++@@ -109,7 +138,9 @@ = "The return type of postulate " ++ show n ++ " is not collapsible" pshow i (AlreadyDefined n) = show n ++ " is already defined" pshow i (ProofSearchFail e) = pshow i e+pshow i (NoRewriting tm) = "rewrite did not change type " ++ show (delab i tm) pshow i (At f e) = show f ++ ":" ++ pshow i e+pshow i (ProviderError msg) = "Type provider error: " ++ msg showSc i [] = "" showSc i xs = "\n\nIn context:\n" ++ showSep "\n" (map showVar (reverse xs))
src/Idris/Docs.hs view
@@ -65,9 +65,9 @@ getDocs :: Name -> Idris Doc getDocs n = do i <- getIState- case lookupCtxt Nothing n (idris_classes i) of+ case lookupCtxt n (idris_classes i) of [ci] -> docClass n ci- _ -> case lookupCtxt Nothing n (idris_datatypes i) of+ _ -> case lookupCtxt n (idris_datatypes i) of [ti] -> docData n ti _ -> do fd <- docFun n return (FunDoc fd)@@ -81,7 +81,7 @@ docClass :: Name -> ClassInfo -> Idris Doc docClass n ci = do i <- getIState- let docstr = case lookupCtxt Nothing n (idris_docstrings i) of+ let docstr = case lookupCtxt n (idris_docstrings i) of [str] -> str _ -> "" mdocs <- mapM docFun (map fst (class_methods ci))@@ -90,13 +90,13 @@ docFun :: Name -> Idris FunDoc docFun n = do i <- getIState- let docstr = case lookupCtxt Nothing n (idris_docstrings i) of+ let docstr = case lookupCtxt n (idris_docstrings i) of [str] -> str _ -> ""- let ty = case lookupTy Nothing n (tt_ctxt i) of+ let ty = case lookupTy n (tt_ctxt i) of (t : _) -> t let argnames = map fst (getArgTys ty)- let args = case lookupCtxt Nothing n (idris_implicits i) of+ let args = case lookupCtxt n (idris_implicits i) of [args] -> zip argnames args _ -> [] let infixes = idris_infixes i
src/Idris/ElabDecls.hs view
@@ -11,11 +11,13 @@ import Idris.ElabTerm import Idris.Coverage import Idris.DataOpts+import Idris.Providers import Paths_idris import Core.TT import Core.Elaborate hiding (Tactic(..)) import Core.Evaluate+import Core.Execute import Core.Typecheck import Core.CaseTree @@ -38,6 +40,7 @@ mapM (\(n, t) -> do (t', _) <- recheckC fc [] t return (n, t')) ns +-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int". elabType :: ElabInfo -> SyntaxInfo -> String -> FC -> FnOpts -> Name -> PTerm -> Idris () elabType info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in @@ -46,6 +49,7 @@ ctxt <- getContext i <- getIState logLvl 3 $ show n ++ " pre-type " ++ showImp True ty'+ ty' <- addUsingConstraints syn fc ty' ty' <- implicit syn n ty' let ty = addImpl i ty' logLvl 2 $ show n ++ " type " ++ showImp True ty@@ -66,7 +70,7 @@ let nty' = normalise ctxt [] nty let (t, _) = unApply (getRetTy nty') let corec = case t of- P _ rcty _ -> case lookupCtxt Nothing rcty (idris_datatypes i) of+ P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of [TI _ True _] -> True _ -> False _ -> False@@ -90,14 +94,14 @@ -- make sure it's collapsible, so it is never needed at run time -- start by getting the elaborated type ctxt <- getContext- fty <- case lookupTy Nothing n ctxt of+ fty <- case lookupTy n ctxt of [] -> tclift $ tfail $ (At fc (NoTypeDecl n)) -- can't happen! [ty] -> return ty ist <- getIState let (ap, _) = unApply (getRetTy (normalise ctxt [] fty)) logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty) let postOK = case ap of- P _ tn _ -> case lookupCtxt Nothing tn+ P _ tn _ -> case lookupCtxt tn (idris_optimisation ist) of [oi] -> collapsible oi _ -> False@@ -118,11 +122,11 @@ ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] (erun fc (build i info False n t)) def' <- checkDef fc defer- addDeferred def'+ addDeferredTyCon def' mapM_ (elabCaseBlock info) is (cty, _) <- recheckC fc [] t' logLvl 2 $ "---> " ++ show cty- updateContext (addTyDecl n cty) -- temporary, to check cons+ updateContext (addTyDecl n (TCon 0 0) cty) -- temporary, to check cons elabData info syn doc fc codata (PDatadecl n t_in dcons) = do iLOG (show fc)@@ -134,17 +138,17 @@ ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] (erun fc (build i info False n t)) def' <- checkDef fc defer- addDeferred def'+ addDeferredTyCon def' mapM_ (elabCaseBlock info) is (cty, _) <- recheckC fc [] t' logLvl 2 $ "---> " ++ show cty -- temporary, to check cons- when undef $ updateContext (addTyDecl n cty) + when undef $ updateContext (addTyDecl n (TCon 0 0) cty) cons <- mapM (elabCon info syn n codata) dcons ttag <- getName i <- getIState let as = map (const Nothing) (getArgTys cty) - let params = findParams (zip as (repeat True)) (map snd cons)+ let params = findParams (map snd cons) logLvl 2 $ "Parameters : " ++ show params putIState (i { idris_datatypes = addDef n (TI (map fst cons) codata params) (idris_datatypes i) })@@ -158,43 +162,113 @@ where -- parameters are names which are unchanged across the structure, -- which appear exactly once in the return type of a constructor- findParams :: [(Maybe Name, Bool)] -> [Type] -> [Int]- findParams ps [] = mapMaybe (\ ((x, y), n) ->- if y then Just n else Nothing)- (zip ps [0..])- findParams ps (t : ts) = findParams (updateParams ps t) ts - updateParams ps (Bind n (Pi t) sc) - = updateParams (updateParams ps (instantiate (P Bound n t) sc)) t- updateParams ps tm@(App f a)- | (P _ fn _, args) <- unApply tm- = if fn == n- then updateParamsA ps args (tail args)- else updateParams (updateParams ps f) a- | otherwise = updateParams (updateParams ps f) a- updateParams ps _ = ps+ -- First, find all applications of the constructor, then check over+ -- them for repeated arguments - updateParamsA ((mn, _) : ns) (p@(P _ n' _) : args) all- | n' `elem` concatMap freeNames all- = (mn, False) : updateParamsA ns args (p : all)- updateParamsA ((Nothing, b) : ns) (p@(P _ n' _) : args) all- = (Just n', b) : updateParamsA ns args (p : all)- updateParamsA ((Just p, b) : ns) (tm@(P _ n' _) : args) all- = (Just n', b && p == n') : updateParamsA ns args (tm : all)- updateParamsA ((mn, _) : ns) (p : args) all- = (mn, False) : updateParamsA ns args (p : all)- updateParamsA ps args all = ps+ findParams :: [Type] -> [Int]+ findParams ts = let allapps = concatMap getDataApp ts in+ paramPos allapps + paramPos [] = []+ paramPos (args : rest) + = dropNothing $ keepSame (zip [0..] args) rest++ dropNothing [] = []+ dropNothing ((x, Nothing) : ts) = dropNothing ts+ dropNothing ((x, _) : ts) = x : dropNothing ts++ keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] -> + [(Int, Maybe Name)]+ keepSame as [] = as+ keepSame as (args : rest) = keepSame (update as args) rest+ where+ update [] _ = []+ update _ [] = []+ update ((n, Just x) : as) (Just x' : args)+ | x == x' = (n, Just x) : update as args+ update ((n, _) : as) (_ : args) = (n, Nothing) : update as args++ getDataApp :: Type -> [[Maybe Name]]+ getDataApp f@(App _ _)+ | (P _ d _, args) <- unApply f+ = if (d == n) then [mParam args args] else []+ getDataApp (Bind n (Pi t) sc)+ = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc)+ getDataApp _ = []++ -- keep the arguments which are single names, which don't appear+ -- elsewhere ++ mParam args [] = []+ mParam args (P Bound n _ : rest)+ | count n args == 1 + = Just n : mParam args rest+ where count n [] = 0+ count n (t : ts) + | n `elem` freeNames t = 1 + count n ts+ | otherwise = count n ts+ mParam args (_ : rest) = Nothing : mParam args rest++-- | Elaborate a type provider+elabProvider :: ElabInfo -> SyntaxInfo -> FC -> Name -> PTerm -> PTerm -> Idris ()+elabProvider info syn fc n ty tm+ = do i <- getIState+ -- Ensure that the experimental extension is enabled+ unless (TypeProviders `elem` idris_language_extensions i) $+ fail $ "Failed to define type provider \"" ++ show n +++ "\".\nYou must turn on the TypeProviders extension."++ ctxt <- getContext++ -- First elaborate the expected type (and check that it's a type)+ (ty', typ) <- elabVal toplevel False ty+ unless (isTType typ) $+ fail ("Expected a type, got " ++ show ty' ++ " : " ++ show typ)++ -- Elaborate the provider term to TT and check that the type matches+ (e, et) <- elabVal toplevel False tm+ unless (isProviderOf ty' et) $+ fail $ "Expected provider type IO (Provider (" +++ show ty' ++ "))" ++ ", got " ++ show et ++ " instead."++ -- Create the top-level type declaration+ elabType info syn "" fc [] n ty++ -- Execute the type provider and normalise the result+ rhs <- execute e+ let rhs' = normalise ctxt [] rhs+ logLvl 1 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs++ -- Extract the provided term from the type provider+ tm <- getProvided rhs'++ -- Finally add a top-level definition of the provided term+ elabClauses info fc [] n [PClause fc n (PRef fc n) [] (delab i tm) []]+ logLvl 1 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm++ where isTType :: TT Name -> Bool+ isTType (TType _) = True+ isTType _ = False++ isProviderOf :: TT Name -> TT Name -> Bool+ isProviderOf tp prov+ | (P _ (UN "IO") _, [prov']) <- unApply prov+ , (P _ (NS (UN "Provider") ["Providers"]) _, [tp']) <- unApply prov'+ , tp == tp' = True+ isProviderOf _ _ = False++ elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name -> PTerm -> String -> Name -> PTerm -> Idris () elabRecord info syn doc fc tyn ty cdoc cn cty = do elabData info syn doc fc False (PDatadecl tyn ty [(cdoc, cn, cty, fc)]) cty' <- implicit syn cn cty i <- getIState- cty <- case lookupTy Nothing cn (tt_ctxt i) of+ cty <- case lookupTy cn (tt_ctxt i) of [t] -> return (delab i t) _ -> fail "Something went inexplicably wrong"- cimp <- case lookupCtxt Nothing cn (idris_implicits i) of+ cimp <- case lookupCtxt cn (idris_implicits i) of [imps] -> return imps let ptys = getProjs [] (renameBs cimp cty) let ptys_u = getProjs [] cty@@ -329,11 +403,13 @@ mkLazy (PPi pl n ty sc) = PPi (pl { plazy = True }) n ty (mkLazy sc) mkLazy t = t +-- | Elaborate a collection of left-hand and right-hand pairs - that is, a+-- top-level definition. elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris () elabClauses info fc opts n_in cs = let n = liftname info n_in in do ctxt <- getContext -- Check n actually exists, with no definition yet- let tys = lookupTy Nothing n ctxt+ let tys = lookupTy n ctxt checkUndefined n ctxt unless (length tys > 1) $ do fty <- case tys of@@ -350,7 +426,7 @@ logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty) -- FIXME: Really ought to only do this for total functions! let doNothing = case ap of- P _ tn _ -> case lookupCtxt Nothing tn+ P _ tn _ -> case lookupCtxt tn (idris_optimisation ist) of [oi] -> collapsible oi _ -> False@@ -358,7 +434,7 @@ solveDeferred n ist <- getIState when doNothing $ - case lookupCtxt Nothing n (idris_optimisation ist) of+ case lookupCtxt n (idris_optimisation ist) of [oi] -> do let opts = addDef n (oi { collapsible = True }) (idris_optimisation ist) putIState (ist { idris_optimisation = opts })@@ -392,14 +468,21 @@ then do missing <- genClauses fc n (map getLHS pdef) cs -- missing <- genMissing n scargs sc missing' <- filterM (checkPossible info fc True n) missing+ let clhs = map getLHS pdef logLvl 2 $ "Must be unreachable:\n" ++ showSep "\n" (map (showImp True) missing') ++ "\nAgainst: " ++ showSep "\n" (map (\t -> showImp True (delab ist t)) (map getLHS pdef))- return missing'+ -- filter out anything in missing' which is+ -- matched by any of clhs. This might happen since+ -- unification may force a variable to take a + -- particular form, rather than force a case+ -- to be impossible.+ return (filter (noMatch ist clhs) missing') else return [] let pcover = null pmissing logLvl 2 $ "Optimising patterns"+ logLvl 5 $ show optpdef pdef' <- applyOpts optpdef logLvl 2 $ "Optimised patterns" logLvl 5 $ show pdef'@@ -428,8 +511,9 @@ logLvl 3 $ "Optimised: " ++ show tree' ctxt <- getContext ist <- getIState- putIState (ist { idris_patdefs = addDef n pdef' (idris_patdefs ist) })- case lookupTy (namespace info) n ctxt of+ putIState (ist { idris_patdefs = addDef n (pdef', pmissing) + (idris_patdefs ist) })+ case lookupTy n ctxt of [ty] -> do updateContext (addCasedef n (inlinable opts) tcase knowncovering (AssertTotal `elem` opts)@@ -440,7 +524,7 @@ totcheck (fc, n) when (tot /= Unchecked) $ addIBC (IBCTotal n tot) i <- getIState- case lookupDef Nothing n (tt_ctxt i) of+ case lookupDef n (tt_ctxt i) of (CaseOp _ _ _ _ _ scargs sc scargs' sc' : _) -> do let calls = findCalls sc' scargs' let used = findUsedArgs sc' scargs'@@ -456,7 +540,11 @@ [] -> return () return () where- checkUndefined n ctxt = case lookupDef Nothing n ctxt of+ noMatch i cs tm = all (\x -> case matchClause i (delab' i x True) tm of+ Right _ -> False+ Left miss -> True) cs ++ checkUndefined n ctxt = case lookupDef n ctxt of [] -> return () [TyDecl _ _] -> return () _ -> tclift $ tfail (At fc (AlreadyDefined n))@@ -522,6 +610,7 @@ case recheck ctxt [] (forget lhs_tm) lhs_tm of OK _ -> return True _ -> return False+ -- b <- inferredDiff fc (delab' i lhs_tm True) lhs -- return (not b) -- then return (Just lhs_tm) else return Nothing -- trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b)@@ -541,14 +630,14 @@ -- pattern bindings i <- getIState -- get the parameters first, to pass through to any where block- let fn_ty = case lookupTy Nothing fname (tt_ctxt i) of+ let fn_ty = case lookupTy fname (tt_ctxt i) of [t] -> t _ -> error "Can't happen (elabClause function type)"- let fn_is = case lookupCtxt Nothing fname (idris_implicits i) of+ let fn_is = case lookupCtxt fname (idris_implicits i) of [t] -> t _ -> [] let params = getParamsInType i [] fn_is fn_ty- let lhs = addImplPat i (propagateParams params lhs_in)+ let lhs = addImplPat i (propagateParams params (stripLinear i lhs_in)) logLvl 5 ("LHS: " ++ show fc ++ " " ++ showImp True lhs) logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is)) ((lhs', dlhs, []), _) <- @@ -648,7 +737,7 @@ = getParamsInType i (n : env) is (instantiate (P Bound n t) sc) getParamsInType i env is tm@(App f a) | (P _ tn _, args) <- unApply tm - = case lookupCtxt Nothing tn (idris_datatypes i) of+ = case lookupCtxt tn (idris_datatypes i) of [t] -> nub $ paramNames args env (param_pos t) ++ getParamsInType i env is f ++ getParamsInType i env is a@@ -681,7 +770,7 @@ -- Build the LHS as an "Infer", and pull out its type and -- pattern bindings i <- getIState- let lhs = addImpl i lhs_in+ let lhs = addImplPat i lhs_in logLvl 5 ("LHS: " ++ showImp True lhs) ((lhs', dlhs, []), _) <- tclift $ elaborate ctxt (MN 0 "patLHS") infP []@@ -779,18 +868,18 @@ mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres) = do i <- getIState- let tm = addImpl i tm_in+ let tm = addImplPat i tm_in logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++ showImp True toplhs) case matchClause i toplhs tm of- Left _ -> fail $ show fc ++ "with clause does not match top level"+ Left f -> fail $ show fc ++ ":with clause does not match top level" Right mvars -> do logLvl 3 ("Match vars : " ++ show mvars) lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w return $ PClause fc wname lhs ws rhs wheres mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs) = do i <- getIState- let tm = addImpl i tm_in+ let tm = addImplPat i tm_in logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++ showImp True toplhs) withs' <- mapM (mkAuxC wname toplhs ns ns') withs@@ -858,7 +947,8 @@ elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc False ddecl -- for each constraint, build a top level function to chase it logLvl 5 $ "Building functions"- let usyn = syn { using = ps ++ using syn }+ let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps + ++ using syn } fns <- mapM (cfun cn constraint usyn (map fst imethods)) constraints mapM_ (elabDecl EAll info) (concat fns) -- for each method, build a top level function@@ -924,7 +1014,7 @@ let conn = case con of PRef _ n -> n PApp _ (PRef _ n) _ -> n- let conn' = case lookupCtxtName Nothing conn (idris_classes i) of+ let conn' = case lookupCtxtName conn (idris_classes i) of [(n, _)] -> n _ -> conn addInstance False conn' cfn@@ -985,7 +1075,7 @@ [PDecl] -> Idris () elabInstance info syn fc cs n ps t expn ds = do i <- getIState - (n, ci) <- case lookupCtxtName (namespace info) n (idris_classes i) of+ (n, ci) <- case lookupCtxtName n (idris_classes i) of [c] -> return c _ -> fail $ show fc ++ ":" ++ show n ++ " is not a type class" let constraint = PApp fc (PRef fc n) (map pexp ps)@@ -1045,7 +1135,7 @@ checkNotOverlapping i t n | take 2 (show n) == "@@" = return () | otherwise- = case lookupTy Nothing n (tt_ctxt i) of+ = case lookupTy n (tt_ctxt i) of [t'] -> let tret = getRetType t tret' = getRetType (delab i t') in case matchClause i tret' tret of@@ -1082,7 +1172,7 @@ | PRef _ n <- getTm p = do ps' <- getWParams ps ctxt <- getContext- case lookupP Nothing n ctxt of+ case lookupP n ctxt of [] -> return (pimp n (PRef fc n) : ps') _ -> return ps' getWParams (_ : ps) = getWParams ps@@ -1217,7 +1307,7 @@ | what /= ETypes = do iLOG $ "Elaborating clause " ++ show n i <- getIState -- get the type options too- let o' = case lookupCtxt Nothing n (idris_flags i) of+ let o' = case lookupCtxt n (idris_flags i) of [fs] -> fs [] -> [] elabClauses info f (o ++ o') n ps@@ -1263,6 +1353,10 @@ addIBC (IBCDSL n) elabDecl' what info (PDirective i) | what /= EDefns = i+elabDecl' what info (PProvider syn fc n tp tm)+ | what /= EDefns+ = do iLOG $ "Elaborating type provider " ++ show n+ elabProvider info syn fc n tp tm elabDecl' _ _ _ = return () -- skipped this time elabCaseBlock info d@(PClauses f o n ps)
src/Idris/ElabTerm.hs view
@@ -13,6 +13,7 @@ import Control.Monad import Control.Monad.State import Data.List+ import Debug.Trace -- Data to pass to recursively called elaborators; e.g. for where blocks,@@ -57,6 +58,7 @@ resolveTC 7 fn ist) ivs probs <- get_probs tm <- get_term+ ctxt <- get_context case probs of [] -> return () ((_,_,_,e):es) -> lift (Error e)@@ -94,9 +96,10 @@ ElabD () elab ist info pattern tcgen fn tm = do elabE (False, False) tm -- (in argument, guarded)+ end_unify when pattern -- convert remaining holes to pattern vars (do update_term orderPats--- tm <- get_term+ tm <- get_term mkPat) where isph arg = case getTm arg of@@ -122,6 +125,15 @@ trace ("Elaborating " ++ show t ++ " : " ++ show g ++ "\n\tin " ++ show tm) $ -} do t' <- insertCoerce ina t+ g <- goal+ tm <- get_term+ ps <- get_probs+ hs <- get_holes+-- trace ("Elaborating " ++ show t' ++ " in " ++ show g+-- -- ++ "\n" ++ show tm +-- ++ "\nholes " ++ show hs+-- ++ "\nproblems " ++ show ps+-- ++ "\n-----------\n") $ elab' ina t' local f = do e <- get_env@@ -199,19 +211,18 @@ = try' (elab' ina x) (trySeq' deferr xs) True elab' ina (PPatvar fc n) | pattern = patvar n elab' (ina, guarded) (PRef fc n) | pattern && not (inparamBlock n)- = do ctxt <- get_context- let iscon = isConName Nothing n ctxt- let defined = case lookupTy Nothing n ctxt of- [] -> False- _ -> True- -- this is to stop us resolve type classes recursively- -- trace (show (n, guarded)) $- if (tcname n && ina) then erun fc $ patvar n- else if (defined && not guarded)- then do apply (Var n) []; solve- else try (do apply (Var n) []; solve)- (patvar n)- where inparamBlock n = case lookupCtxtName Nothing n (inblock info) of+ = do ctxt <- get_context+ let defined = case lookupTy n ctxt of+ [] -> False+ _ -> True+ -- this is to stop us resolve type classes recursively+ -- trace (show (n, guarded)) $+ if (tcname n && ina) then erun fc $ patvar n+ else if (defined && not guarded)+ then do apply (Var n) []; solve+ else try (do apply (Var n) []; solve)+ (patvar n)+ where inparamBlock n = case lookupCtxtName n (inblock info) of [] -> False _ -> True elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])@@ -221,6 +232,7 @@ -- let sc' = mapPT (repN n n') sc ptm <- get_term g <- goal+ checkPiGoal attack; intro (Just n); -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm) elabE (True, a) sc; solve@@ -230,6 +242,7 @@ = do hsin <- get_holes ptmin <- get_term tyn <- unique_hole (MN 0 "lamty")+ checkPiGoal claim tyn RType attack ptm <- get_term@@ -322,7 +335,7 @@ elab' (ina, g) tm@(PApp fc (PRef _ f) args') = do let args = {- case lookupCtxt f (inblock info) of Just ps -> (map (pexp . (PRef fc)) ps ++ args')- _ ->-} args'+ _ -> -} args' -- newtm <- mkSpecialised ist fc f (map getTm args') tm env <- get_env if (f `elem` map fst env && length args' == 1)@@ -338,11 +351,11 @@ let isinf = f == inferCon || tcname f -- if f is a type class, we need to know its arguments so that -- we can unify with them- case lookupCtxt Nothing f (idris_classes ist) of+ case lookupCtxt f (idris_classes ist) of [] -> return () _ -> mapM_ setInjective (map getTm args') ctxt <- get_context- let guarded = isConName Nothing f ctxt+ let guarded = isConName f ctxt ns <- apply (Var f) (map isph args) ptm <- get_term g <- goal@@ -398,6 +411,23 @@ | not pattern = do mapM_ (runTac False ist) ts | otherwise = elab' ina Placeholder elab' ina (PElabError e) = fail (pshow ist e)+ elab' ina (PRewrite fc r sc) + = do attack+ tyn <- unique_hole (MN 0 "rty")+ claim tyn RType+ valn <- unique_hole (MN 0 "rval")+ claim valn (Var tyn)+ letn <- unique_hole (MN 0 "rewrite_rule")+ letbind letn (Var tyn) (Var valn) + focus valn+ elab' ina r+ compute+ g <- goal+ rewrite (Var letn)+ g' <- goal+ when (g == g') $ lift $ tfail (NoRewriting g)+ elab' ina sc+ solve elab' ina@(_, a) c@(PCase fc scr opts) = do attack tyn <- unique_hole (MN 0 "scty")@@ -417,6 +447,8 @@ -- fail $ "Not implemented " ++ show c ++ "\n" ++ show args -- elaborate case updateAux (newdef : )+ -- if we haven't got the type yet, hopefully we'll get it later!+ movelast tyn solve where mkCaseName (NS n ns) = NS (mkCaseName n) ns mkCaseName (UN x) = UN (x ++ "_case")@@ -477,7 +509,6 @@ where elabArg n t = do hs <- get_holes tm <- get_term- t' <- insertCoerce ina t failed' <- -- trace (show (n, t, hs, tm)) $ -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $ case n `elem` hs of@@ -485,7 +516,7 @@ -- if r -- then try (do focus n; elabE ina t; return failed) -- (return ((n,(lazy, t)):failed))- do focus n; elab' ina t'; return failed+ do focus n; elabE ina t; return failed False -> return failed elabArgs ina failed fc r ns args @@ -517,7 +548,7 @@ pruneByType :: Term -> Context -> [PTerm] -> [PTerm] pruneByType (P _ n _) c as -- if the goal type is polymorphic, keep e- | [] <- lookupTy Nothing n c = as+ | [] <- lookupTy n c = as | otherwise = let asV = filter (headIs True n) as as' = filter (headIs False n) as in@@ -533,8 +564,9 @@ headIs _ _ _ = True -- keep if it's not an application typeHead var f f' - = case lookupTy Nothing f' c of- [ty] -> case unApply (getRetTy ty) of+ = 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@@ -565,7 +597,7 @@ findInstances :: IState -> Term -> [Name] findInstances ist t | (P _ n _, _) <- unApply t - = case lookupCtxt Nothing n (idris_classes ist) of+ = case lookupCtxt n (idris_classes ist) of [CI _ _ _ _ ins] -> ins _ -> [] | otherwise = []@@ -627,7 +659,7 @@ -- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist -- else do -- if there's a hole in the goal, don't even try- let imps = case lookupCtxtName Nothing n (idris_implicits ist) of+ let imps = case lookupCtxtName n (idris_implicits ist) of [] -> [] [args] -> map isImp (snd args) -- won't be overloaded! ps <- get_probs@@ -664,10 +696,12 @@ collectDeferred t = return t -- Running tactics directly+-- if a tactic adds unification problems, return an error runTac :: Bool -> IState -> PTactic -> ElabD ()-runTac autoSolve ist tac = do env <- get_env- runT (fmap (addImplBound ist (map fst env)) tac) +runTac autoSolve ist tac + = do env <- get_env+ no_errors $ runT (fmap (addImplBound ist (map fst env)) tac) where runT (Intro []) = do g <- goal attack; intro (bname g)@@ -685,7 +719,7 @@ runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm when autoSolve solveAll runT (Refine fn []) - = do (fn', imps) <- case lookupCtxtName Nothing fn (idris_implicits ist) of+ = do (fn', imps) <- case lookupCtxtName fn (idris_implicits ist) of [] -> do a <- envArgs fn return (fn, a) -- FIXME: resolve ambiguities@@ -744,22 +778,67 @@ runT Solve = solve runT (Try l r) = do try' (runT l) (runT r) True runT (TSeq l r) = do runT l; runT r- runT (ReflectTac tm) = do attack -- let x : Tactic = tm in ...- valn <- unique_hole (MN 0 "tacval")- claim valn (Var tacticTy)- tacn <- unique_hole (MN 0 "tacn")- letbind tacn (Var tacticTy) (Var valn)- focus valn- elab ist toplevel False False (MN 0 "tac") tm- (tm', ty') <- get_type_val (Var tacn)- ctxt <- get_context- env <- get_env- let tactic = normalise ctxt env tm'- runReflected tactic--- p <- get_term--- trace (show p ++ "\n\n") $ - return ()- where tacticTy = tacm "Tactic"+ runT (ApplyTactic tm) = do tenv <- get_env -- store the environment+ tgoal <- goal -- store the goal+ attack -- let f : List (TTName, Binder TT) -> TT -> Tactic = tm in ...+ script <- unique_hole (MN 0 "script")+ claim script scriptTy+ scriptvar <- unique_hole (MN 0 "scriptvar" )+ letbind scriptvar scriptTy (Var script)+ focus script+ elab ist toplevel False False (MN 0 "tac") tm+ (script', _) <- get_type_val (Var scriptvar)+ -- now that we have the script apply+ -- it to the reflected goal and context+ restac <- unique_hole (MN 0 "restac")+ claim restac tacticTy+ focus restac+ fill (raw_apply (forget script') + [reflectEnv tenv, reflect tgoal])+ restac' <- get_guess+ solve+ -- normalise the result in order to+ -- reify it+ ctxt <- get_context+ env <- get_env+ let tactic = normalise ctxt env restac'+ runReflected tactic+ where tacticTy = Var (reflm "Tactic")+ listTy = Var (NS (UN "List") ["List", "Prelude"])+ scriptTy = (RBind (UN "__pi_arg") + (Pi (RApp listTy envTupleType))+ (RBind (UN "__pi_arg1") + (Pi (Var $ reflm "TT")) tacticTy))++ runT (Reflect v) = do attack -- let x = reflect v in ...+ tyn <- unique_hole (MN 0 "letty")+ claim tyn RType+ valn <- unique_hole (MN 0 "letval")+ claim valn (Var tyn)+ letn <- unique_hole (MN 0 "letvar")+ letbind letn (Var tyn) (Var valn)+ focus valn+ elab ist toplevel False False (MN 0 "tac") v+ (value, _) <- get_type_val (Var letn)+ ctxt <- get_context+ env <- get_env+ let value' = hnf ctxt env value+ runTac autoSolve ist (Exact $ PQuote (reflect value'))+ runT (Fill v) = do attack -- let x = fill x in ...+ tyn <- unique_hole (MN 0 "letty")+ claim tyn RType+ valn <- unique_hole (MN 0 "letval")+ claim valn (Var tyn)+ letn <- unique_hole (MN 0 "letvar")+ letbind letn (Var tyn) (Var valn)+ focus valn+ elab ist toplevel False False (MN 0 "tac") v+ (value, _) <- get_type_val (Var letn)+ ctxt <- get_context+ env <- get_env+ let value' = normalise ctxt env value+ rawValue <- reifyRaw value'+ runTac autoSolve ist (Exact $ PQuote rawValue) runT (GoalType n tac) = do g <- goal case unApply g of (P _ n' _, _) -> @@ -769,25 +848,352 @@ _ -> fail "Wrong goal type" runT x = fail $ "Not implemented " ++ show x - runReflected t = do t' <- reify t+ runReflected t = do t' <- reify ist t runTac autoSolve ist t'- tacm n = NS (UN n) ["Reflection", "Language"] - reify :: Term -> ElabD PTactic- reify (P _ n _) | n == tacm "Trivial" = return Trivial- reify (P _ n _) | n == tacm "Solve" = return Solve- reify f@(App _ _) - | (P _ f _, args) <- unApply f = reifyAp f args- reify t = fail ("Unknown tactic " ++ show t)+-- | Prefix a name with the "Reflection.Language" namespace+reflm :: String -> Name+reflm n = NS (UN n) ["Reflection", "Language"] - reifyAp t [l, r] | t == tacm "Try" = liftM2 Try (reify l) (reify r)- reifyAp t [Constant (Str x)] - | t == tacm "Refine" = return $ Refine (UN x) []- reifyAp t [l, r] | t == tacm "Seq" = liftM2 TSeq (reify l) (reify r)- reifyAp t [Constant (Str n), x] - | t == tacm "GoalType" = liftM (GoalType n) (reify x)- reifyAp f args = fail ("Unknown tactic " ++ show (f, args)) -- shouldn't happen +-- | Reify tactics from their reflected representation+reify :: IState -> Term -> ElabD PTactic+reify _ (P _ n _) | n == reflm "Intros" = return Intros+reify _ (P _ n _) | n == reflm "Trivial" = return Trivial+reify _ (P _ n _) | n == reflm "Solve" = return Solve+reify _ (P _ n _) | n == reflm "Compute" = return Compute+reify ist t@(App _ _)+ | (P _ f _, args) <- unApply t = reifyApp ist f args+reify _ t = fail ("Unknown tactic " ++ show t)++reifyApp :: IState -> Name -> [Term] -> ElabD PTactic+reifyApp ist t [l, r] | t == reflm "Try" = liftM2 Try (reify ist l) (reify ist r)+reifyApp _ t [x]+ | t == reflm "Refine" = do n <- reifyTTName x+ return $ Refine n []+reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist r)+reifyApp ist t [Constant (Str n), x]+ | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)+reifyApp _ t [Constant (Str n)]+ | t == reflm "Intro" = return $ Intro [UN n]+reifyApp ist t [t'] + | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')+reifyApp ist t [t']+ | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')+reifyApp _ t [t']+ | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t')+reifyApp ist t [t']+ | t == reflm "Exact" = liftM (Exact . delab ist) (reifyTT t')+reifyApp ist t [x]+ | t == reflm "Focus" = liftM Focus (reifyTTName x)+reifyApp ist t [t']+ | t == reflm "Rewrite" = liftM (Rewrite . delab ist) (reifyTT t')+reifyApp ist t [n, t']+ | t == reflm "LetTac" = do n' <- reifyTTName n+ t'' <- reifyTT t'+ return $ LetTac n' (delab ist t')+reifyApp ist t [n, tt', t']+ | t == reflm "LetTacTy" = do n' <- reifyTTName n+ tt'' <- reifyTT tt'+ t'' <- reifyTT t'+ return $ LetTacTy n' (delab ist tt'') (delab ist t'')+reifyApp _ f args = fail ("Unknown tactic " ++ show (f, args)) -- shouldn't happen++-- | Reify terms from their reflected representation+reifyTT :: Term -> ElabD Term+reifyTT t@(App _ _)+ | (P _ f _, args) <- unApply t = reifyTTApp f args+reifyTT t@(P _ n _)+ | n == reflm "Erased" = return $ Erased+reifyTT t@(P _ n _)+ | n == reflm "Impossible" = return $ Impossible+reifyTT t = fail ("Unknown reflection term: " ++ show t)++reifyTTApp :: Name -> [Term] -> ElabD Term+reifyTTApp t [nt, n, x]+ | t == reflm "P" = do nt' <- reifyTTNameType nt+ n' <- reifyTTName n+ x' <- reifyTT x+ return $ P nt' n' x'+reifyTTApp t [Constant (I i)]+ | t == reflm "V" = return $ V i+reifyTTApp t [n, b, x]+ | t == reflm "Bind" = do n' <- reifyTTName n+ b' <- reifyTTBinder reifyTT (reflm "TT") b+ x' <- reifyTT x+ return $ Bind n' b' x'+reifyTTApp t [f, x]+ | t == reflm "App" = do f' <- reifyTT f+ x' <- reifyTT x+ return $ App f' x'+reifyTTApp t [c]+ | t == reflm "TConst" = liftM Constant (reifyTTConst c)+reifyTTApp t [t', Constant (I i)]+ | t == reflm "Proj" = do t'' <- reifyTT t'+ return $ Proj t'' i+reifyTTApp t [tt]+ | t == reflm "TType" = liftM TType (reifyTTUExp tt)+reifyTTApp t args = fail ("Unknown reflection term: " ++ show (t, args))++-- | Reify raw terms from their reflected representation+reifyRaw :: Term -> ElabD Raw+reifyRaw t@(App _ _)+ | (P _ f _, args) <- unApply t = reifyRawApp f args+reifyRaw t@(P _ n _)+ | n == reflm "RType" = return $ RType+reifyRaw t = fail ("Unknown reflection raw term: " ++ show t)++reifyRawApp :: Name -> [Term] -> ElabD Raw+reifyRawApp t [n]+ | t == reflm "Var" = liftM Var (reifyTTName n)+reifyRawApp t [n, b, x]+ | t == reflm "RBind" = do n' <- reifyTTName n+ b' <- reifyTTBinder reifyRaw (reflm "Raw") b+ x' <- reifyRaw x+ return $ RBind n' b' x'+reifyRawApp t [f, x]+ | t == reflm "RApp" = liftM2 RApp (reifyRaw f) (reifyRaw x)+reifyRawApp t [t']+ | t == reflm "RForce" = liftM RForce (reifyRaw t')+reifyRawApp t [c]+ | t == reflm "RConstant" = liftM RConstant (reifyTTConst c)+reifyRawApp t args = fail ("Unknown reflection raw term: " ++ show (t, args))++reifyTTName :: Term -> ElabD Name+reifyTTName t@(App _ _)+ | (P _ f _, args) <- unApply t = reifyTTNameApp f args+reifyTTName t = fail ("Unknown reflection term name: " ++ show t)++reifyTTNameApp :: Name -> [Term] -> ElabD Name+reifyTTNameApp t [Constant (Str n)]+ | t == reflm "UN" = return $ UN n+reifyTTNameApp t [n, ns]+ | t == reflm "NS" = do n' <- reifyTTName n+ ns' <- reifyTTNamespace ns+ return $ NS n' ns'+reifyTTNameApp t [Constant (I i), Constant (Str n)]+ | t == reflm "MN" = return $ MN i n+reifyTTNameApp t []+ | t == reflm "NErased" = return NErased+reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))++reifyTTNamespace :: Term -> ElabD [String]+reifyTTNamespace t@(App _ _) + = case unApply t of+ (P _ f _, [Constant StrType]) + | f == NS (UN "Nil") ["List", "Prelude"] -> return []+ (P _ f _, [Constant StrType, Constant (Str n), ns])+ | f == NS (UN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns)+ _ -> fail ("Unknown reflection namespace arg: " ++ show t)+reifyTTNamespace t = fail ("Unknown reflection namespace arg: " ++ show t)++reifyTTNameType :: Term -> ElabD NameType+reifyTTNameType t@(P _ n _) | n == reflm "Bound" = return $ Bound+reifyTTNameType t@(P _ n _) | n == reflm "Ref" = return $ Ref+reifyTTNameType t@(App _ _)+ = case unApply t of+ (P _ f _, [Constant (I tag), Constant (I num)])+ | f == reflm "DCon" -> return $ DCon tag num+ | f == reflm "TCon" -> return $ TCon tag num+ _ -> fail ("Unknown reflection name type: " ++ show t)+reifyTTNameType t = fail ("Unknown reflection name type: " ++ show t)++reifyTTBinder :: (Term -> ElabD a) -> Name -> Term -> ElabD (Binder a)+reifyTTBinder reificator binderType t@(App _ _)+ = case unApply t of+ (P _ f _, bt:args) | forget bt == Var binderType + -> reifyTTBinderApp reificator f args+ _ -> fail ("Mismatching binder reflection: " ++ show t)+reifyTTBinder _ _ t = fail ("Unknown reflection binder: " ++ show t)++reifyTTBinderApp :: (Term -> ElabD a) -> Name -> [Term] -> ElabD (Binder a)+reifyTTBinderApp reif f [t]+ | f == reflm "Lam" = liftM Lam (reif t)+reifyTTBinderApp reif f [t]+ | f == reflm "Pi" = liftM Pi (reif t)+reifyTTBinderApp reif f [x, y]+ | f == reflm "Let" = liftM2 Let (reif x) (reif y)+reifyTTBinderApp reif f [x, y]+ | f == reflm "NLet" = liftM2 NLet (reif x) (reif y)+reifyTTBinderApp reif f [t]+ | f == reflm "Hole" = liftM Hole (reif t)+reifyTTBinderApp reif f [t]+ | f == reflm "GHole" = liftM GHole (reif t)+reifyTTBinderApp reif f [x, y]+ | f == reflm "Guess" = liftM2 Guess (reif x) (reif y)+reifyTTBinderApp reif f [t]+ | f == reflm "PVar" = liftM PVar (reif t)+reifyTTBinderApp reif f [t]+ | f == reflm "PVTy" = liftM PVTy (reif t)+reifyTTBinderApp _ f args = fail ("Unknown reflection binder: " ++ show (f, args))++reifyTTConst :: Term -> ElabD Const+reifyTTConst (P _ n _) | n == reflm "IType" = return $ IType+reifyTTConst (P _ n _) | n == reflm "BIType" = return $ BIType+reifyTTConst (P _ n _) | n == reflm "FlType" = return $ FlType+reifyTTConst (P _ n _) | n == reflm "ChType" = return $ ChType+reifyTTConst (P _ n _) | n == reflm "StrType" = return $ StrType+reifyTTConst (P _ n _) | n == reflm "B8Type" = return $ B8Type+reifyTTConst (P _ n _) | n == reflm "B16Type" = return $ B16Type+reifyTTConst (P _ n _) | n == reflm "B32Type" = return $ B32Type+reifyTTConst (P _ n _) | n == reflm "B64Type" = return $ B64Type+reifyTTConst (P _ n _) | n == reflm "PtrType" = return $ PtrType+reifyTTConst (P _ n _) | n == reflm "VoidType" = return $ VoidType+reifyTTConst (P _ n _) | n == reflm "Forgot" = return $ Forgot+reifyTTConst t@(App _ _)+ | (P _ f _, [arg]) <- unApply t = reifyTTConstApp f arg+reifyTTConst t = fail ("Unknown reflection constant: " ++ show t)++reifyTTConstApp :: Name -> Term -> ElabD Const+reifyTTConstApp f (Constant c@(I _))+ | f == reflm "I" = return $ c+reifyTTConstApp f (Constant c@(BI _))+ | f == reflm "BI" = return $ c+reifyTTConstApp f (Constant c@(Fl _))+ | f == reflm "Fl" = return $ c+reifyTTConstApp f (Constant c@(I _))+ | f == reflm "Ch" = return $ c+reifyTTConstApp f (Constant c@(Str _))+ | f == reflm "Str" = return $ c+reifyTTConstApp f (Constant c@(B8 _))+ | f == reflm "B8" = return $ c+reifyTTConstApp f (Constant c@(B16 _))+ | f == reflm "B16" = return $ c+reifyTTConstApp f (Constant c@(B32 _))+ | f == reflm "B32" = return $ c+reifyTTConstApp f (Constant c@(B64 _))+ | f == reflm "B64" = return $ c+reifyTTConstApp f arg = fail ("Unknown reflection constant: " ++ show (f, arg))++reifyTTUExp :: Term -> ElabD UExp+reifyTTUExp t@(App _ _)+ = case unApply t of+ (P _ f _, [Constant (I i)]) | f == reflm "UVar" -> return $ UVar i+ (P _ f _, [Constant (I i)]) | f == reflm "UVal" -> return $ UVal i+ _ -> fail ("Unknown reflection type universe expression: " ++ show t)+reifyTTUExp t = fail ("Unknown reflection type universe expression: " ++ show t)++-- | Create a reflected call to a named function/constructor+reflCall :: String -> [Raw] -> Raw+reflCall funName args + = raw_apply (Var (reflm funName)) args++-- | Lift a term into its Language.Reflection.TT representation+reflect :: Term -> Raw+reflect (P nt n t) + = reflCall "P" [reflectNameType nt, reflectName n, reflect t]+reflect (V n) + = reflCall "V" [RConstant (I n)]+reflect (Bind n b x)+ = reflCall "Bind" [reflectName n, reflectBinder b, reflect x]+reflect (App f x)+ = reflCall "App" [reflect f, reflect x]+reflect (Constant c)+ = reflCall "TConst" [reflectConstant c]+reflect (Proj t i)+ = reflCall "Proj" [reflect t, RConstant (I i)]+reflect (Erased) = Var (reflm "Erased")+reflect (Impossible) = Var (reflm "Impossible")+reflect (TType exp) = reflCall "TType" [reflectUExp exp]++reflectNameType :: NameType -> Raw+reflectNameType (Bound) = Var (reflm "Bound")+reflectNameType (Ref) = Var (reflm "Ref")+reflectNameType (DCon x y) + = reflCall "DCon" [RConstant (I x), RConstant (I y)]+reflectNameType (TCon x y) + = reflCall "TCon" [RConstant (I x), RConstant (I y)]++reflectName :: Name -> Raw+reflectName (UN str) + = reflCall "UN" [RConstant (Str str)]+reflectName (NS n ns)+ = reflCall "NS" [ reflectName n+ , foldr (\ n s -> + raw_apply ( Var $ NS (UN "::") ["List", "Prelude"] )+ [ RConstant StrType, RConstant (Str n), s ])+ ( raw_apply ( Var $ NS (UN "Nil") ["List", "Prelude"] )+ [ RConstant StrType ])+ ns + ] +reflectName (MN i n) + = reflCall "MN" [RConstant (I i), RConstant (Str n)]+reflectName (NErased) = Var (reflm "NErased")++reflectBinder :: Binder Term -> Raw+reflectBinder (Lam t)+ = reflCall "Lam" [Var (reflm "TT"), reflect t]+reflectBinder (Pi t)+ = reflCall "Pi" [Var (reflm "TT"), reflect t]+reflectBinder (Let x y)+ = reflCall "Let" [Var (reflm "TT"), reflect x, reflect y]+reflectBinder (NLet x y)+ = reflCall "NLet" [Var (reflm "TT"), reflect x, reflect y]+reflectBinder (Hole t)+ = reflCall "Hole" [Var (reflm "TT"), reflect t]+reflectBinder (GHole t)+ = reflCall "GHole" [Var (reflm "TT"), reflect t]+reflectBinder (Guess x y)+ = reflCall "Guess" [Var (reflm "TT"), reflect x, reflect y]+reflectBinder (PVar t)+ = reflCall "PVar" [Var (reflm "TT"), reflect t]+reflectBinder (PVTy t)+ = reflCall "PVTy" [Var (reflm "TT"), reflect t]++reflectConstant :: Const -> Raw+reflectConstant c@(I _) = reflCall "I" [RConstant c]+reflectConstant c@(BI _) = reflCall "BI" [RConstant c]+reflectConstant c@(Fl _) = reflCall "Fl" [RConstant c]+reflectConstant c@(Ch _) = reflCall "Ch" [RConstant c]+reflectConstant c@(Str _) = reflCall "Str" [RConstant c]+reflectConstant (IType) = Var (reflm "IType")+reflectConstant (BIType) = Var (reflm "BIType")+reflectConstant (FlType) = Var (reflm "FlType")+reflectConstant (ChType) = Var (reflm "ChType")+reflectConstant (StrType) = Var (reflm "StrType")+reflectConstant c@(B8 _) = reflCall "B8" [RConstant c]+reflectConstant c@(B16 _) = reflCall "B16" [RConstant c]+reflectConstant c@(B32 _) = reflCall "B32" [RConstant c]+reflectConstant c@(B64 _) = reflCall "B64" [RConstant c]+reflectConstant (B8Type) = Var (reflm "B8Type")+reflectConstant (B16Type) = Var (reflm "B16Type")+reflectConstant (B32Type) = Var (reflm "B32Type")+reflectConstant (B64Type) = Var (reflm "B64Type")+reflectConstant (PtrType) = Var (reflm "PtrType")+reflectConstant (VoidType) = Var (reflm "VoidType")+reflectConstant (Forgot) = Var (reflm "Forgot")++reflectUExp :: UExp -> Raw+reflectUExp (UVar i) = reflCall "UVar" [RConstant (I i)]+reflectUExp (UVal i) = reflCall "UVal" [RConstant (I i)]++-- | Reflect the environment of a proof into a List (TTName, Binder TT)+reflectEnv :: Env -> Raw+reflectEnv = foldr consToEnvList emptyEnvList+ where+ consToEnvList :: (Name, Binder Term) -> Raw -> Raw+ consToEnvList (n, b) l+ = raw_apply (Var (NS (UN "::") ["List", "Prelude"]))+ [ envTupleType+ , raw_apply (Var pairCon) [ (Var $ reflm "TTName")+ , (RApp (Var $ reflm "Binder") + (Var $ reflm "TT"))+ , reflectName n + , reflectBinder b+ ]+ , l+ ]++ emptyEnvList :: Raw+ emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"])) + [envTupleType]++envTupleType :: Raw+envTupleType + = raw_apply (Var pairTy) [ (Var $ reflm "TTName") + , (RApp (Var $ reflm "Binder") (Var $ reflm "TT"))+ ]+ solveAll = try (do solve; solveAll) (return ()) -- If the function application is specialisable, make a new@@ -797,7 +1203,7 @@ mkSpecialised :: IState -> FC -> Name -> [PTerm] -> PTerm -> ElabD PTerm mkSpecialised i fc n args def = do let tm' = def- case lookupCtxt Nothing n (idris_statics i) of+ case lookupCtxt n (idris_statics i) of [] -> return tm' [as] -> if (not (or as)) then return tm' else mkSpecDecl i n (zip args as) tm'@@ -824,8 +1230,8 @@ cg = idris_callgraph i staticFnNames tm | (P _ f _, as) <- unApply tm- = if not (isFnName Nothing f ctxt) then [] - else case lookupCtxt Nothing f cg of+ = if not (isFnName f ctxt) then [] + else case lookupCtxt f cg of [ns] -> f : f : [] --(ns \\ [f]) [] -> [f,f] _ -> []
src/Idris/Error.hs view
@@ -45,7 +45,7 @@ ifail :: String -> Idris () ifail str = throwIO (IErr str) -ierror :: Err -> Idris ()+ierror :: Err -> Idris a ierror err = do i <- getIState throwIO (IErr $ pshow i err)
+ src/Idris/Help.hs view
@@ -0,0 +1,50 @@+module Idris.Help (CmdArg(..), help) where++data CmdArg = ExprArg -- ^ The command takes an expression+ | NameArg -- ^ The command takes a name+ | FileArg -- ^ The command takes a file+ | ModuleArg -- ^ The command takes a module name+ | OptionArg -- ^ The command takes an option+ | MetaVarArg -- ^ The command takes a metavariable+ | NoArg -- ^ No completion (yet!?)+ | SpecialHeaderArg -- ^ do not use++instance Show CmdArg where+ show ExprArg = "<expr>"+ show NameArg = "<name>"+ show FileArg = "<filename>"+ show ModuleArg = "<module>"+ show OptionArg = "<option>"+ show MetaVarArg = "<metavar>"+ show NoArg = ""+ show SpecialHeaderArg = "Arguments"++help :: [([String], CmdArg, String)]+help =+ [ (["<expr>"], NoArg, "Evaluate an expression"),+ ([":t"], ExprArg, "Check the type of an expression"),+ ([":miss", ":missing"], NameArg, "Show missing clauses"),+ ([":i", ":info"], NameArg, "Display information about a type class"),+ ([":total"], NameArg, "Check the totality of a name"),+ ([":r",":reload"], NoArg, "Reload current file"),+ ([":l",":load"], FileArg, "Load a new file"),+ ([":cd"], FileArg, "Change working directory"),+ ([":m",":module"], ModuleArg, "Import an extra module"), -- NOTE: dragons+ ([":e",":edit"], NoArg, "Edit current file using $EDITOR or $VISUAL"),+ ([":m",":metavars"], MetaVarArg, "Show remaining proof obligations (metavariables)"),+ ([":p",":prove"], MetaVarArg, "Prove a metavariable"),+ ([":a",":addproof"], NameArg, "Add proof to source file"),+ ([":rmproof"], NameArg, "Remove proof from proof stack"),+ ([":showproof"], NameArg, "Show proof"),+ ([":proofs"], NoArg, "Show available proofs"),+ ([":x"], ExprArg, "Execute IO actions resulting from an expression using the interpreter"),+ ([":c",":compile"], FileArg, "Compile to an executable <filename>"),+ ([":js", ":javascript"], FileArg, "Compile to JavaScript <filename>"),+ ([":exec",":execute"], NoArg, "Compile to an executable and run"),+ ([":dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)"),+ ([":dynamic"], NoArg, "List dynamically loaded C libraries"),+ ([":?",":h",":help"], NoArg, "Display this help text"),+ ([":set"], OptionArg, "Set an option (errorcontext, showimplicits)"),+ ([":unset"], OptionArg, "Unset an option"),+ ([":q",":quit"], NoArg, "Exit the Idris system")+ ]
src/Idris/IBC.hs view
@@ -18,10 +18,12 @@ import System.FilePath import System.Directory +import Debug.Trace+ import Paths_idris ibcVersion :: Word8-ibcVersion = 27+ibcVersion = 29 data IBCFile = IBCFile { ver :: Word8, sourcefile :: FilePath,@@ -38,6 +40,7 @@ ibc_keywords :: [String], ibc_objs :: [FilePath], ibc_libs :: [String],+ ibc_dynamic_libs :: [String], ibc_hdrs :: [String], ibc_access :: [(Name, Accessibility)], ibc_total :: [(Name, Totality)],@@ -47,12 +50,13 @@ ibc_docstrings :: [(Name, String)], ibc_coercions :: [Name] }+ deriving Show {-! deriving instance Binary IBCFile !-} initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] loadIBC :: FilePath -> Idris () loadIBC fp = do iLOG $ "Loading ibc " ++ fp@@ -81,28 +85,28 @@ mkIBC is f' ibc i (IBCFix d) f = return f { ibc_fixes = d : ibc_fixes f } -ibc i (IBCImp n) f = case lookupCtxt Nothing n (idris_implicits i) of+ibc i (IBCImp n) f = case lookupCtxt n (idris_implicits i) of [v] -> return f { ibc_implicits = (n,v): ibc_implicits f } _ -> fail "IBC write failed" ibc i (IBCStatic n) f - = case lookupCtxt Nothing n (idris_statics i) of+ = case lookupCtxt n (idris_statics i) of [v] -> return f { ibc_statics = (n,v): ibc_statics f } _ -> fail "IBC write failed" ibc i (IBCClass n) f - = case lookupCtxt Nothing n (idris_classes i) of+ = case lookupCtxt n (idris_classes i) of [v] -> return f { ibc_classes = (n,v): ibc_classes f } _ -> fail "IBC write failed" ibc i (IBCInstance int n ins) f = return f { ibc_instances = (int,n,ins): ibc_instances f } ibc i (IBCDSL n) f - = case lookupCtxt Nothing n (idris_dsls i) of+ = case lookupCtxt n (idris_dsls i) of [v] -> return f { ibc_dsls = (n,v): ibc_dsls f } _ -> fail "IBC write failed" ibc i (IBCData n) f - = case lookupCtxt Nothing n (idris_datatypes i) of+ = case lookupCtxt n (idris_datatypes i) of [v] -> return f { ibc_datatypes = (n,v): ibc_datatypes f } _ -> fail "IBC write failed"-ibc i (IBCOpt n) f = case lookupCtxt Nothing n (idris_optimisation i) of+ibc i (IBCOpt n) f = case lookupCtxt n (idris_optimisation i) of [v] -> return f { ibc_optimise = (n,v): ibc_optimise f } _ -> fail "IBC write failed" ibc i (IBCSyntax n) f = return f { ibc_syntax = n : ibc_syntax f }@@ -110,14 +114,15 @@ ibc i (IBCImport n) f = return f { ibc_imports = n : ibc_imports f } ibc i (IBCObj n) f = return f { ibc_objs = n : ibc_objs f } ibc i (IBCLib n) f = return f { ibc_libs = n : ibc_libs f }+ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f } ibc i (IBCHeader n) f = return f { ibc_hdrs = n : ibc_hdrs f }-ibc i (IBCDef n) f = case lookupDef Nothing n (tt_ctxt i) of+ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of [v] -> return f { ibc_defs = (n,v) : ibc_defs f } _ -> fail "IBC write failed"-ibc i (IBCDoc n) f = case lookupCtxt Nothing n (idris_docstrings i) of+ibc i (IBCDoc n) f = case lookupCtxt n (idris_docstrings i) of [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f } _ -> fail "IBC write failed"-ibc i (IBCCG n) f = case lookupCtxt Nothing n (idris_callgraph i) of+ibc i (IBCCG n) f = case lookupCtxt n (idris_callgraph i) of [v] -> return f { ibc_cg = (n,v) : ibc_cg f } _ -> fail "IBC write failed" ibc i (IBCCoercion n) f = return f { ibc_coercions = n : ibc_coercions f }@@ -147,6 +152,7 @@ pKeywords (ibc_keywords i) pObjs (ibc_objs i) pLibs (ibc_libs i)+ pDyLibs (ibc_dynamic_libs i) pHdrs (ibc_hdrs i) pDefs (ibc_defs i) pAccess (ibc_access i)@@ -242,6 +248,13 @@ pLibs :: [String] -> Idris () pLibs ls = mapM_ addLib ls +pDyLibs :: [String] -> Idris ()+pDyLibs ls = do res <- mapM (addDyLib . return) ls+ mapM_ checkLoad res+ return ()+ where checkLoad (Left _) = return ()+ checkLoad (Right err) = fail err+ pHdrs :: [String] -> Idris () pHdrs hs = mapM_ addHdr hs @@ -321,16 +334,21 @@ instance Binary Name where put x- = case x of- UN x1 -> do putWord8 0- put x1- NS x1 x2 -> do putWord8 1+ = {-# SCC "putName" #-}+ case x of+ UN x1 -> {-# SCC "putUN" #-}+ do putWord8 0+ {-# SCC "putNString" #-} put x1+ NS x1 x2 -> {-# SCC "putNS" #-}+ do putWord8 1 put x1 put x2- MN x1 x2 -> do putWord8 2+ MN x1 x2 -> {-# SCC "putMN" #-}+ do putWord8 2 put x1 put x2- NErased -> putWord8 3+ NErased -> {-# SCC "putNErased" #-}+ putWord8 3 get = do i <- getWord8 case i of@@ -522,9 +540,10 @@ _ -> error "Corrupted binary data for NameType" -instance (Binary n) => Binary (TT n) where+instance {-(Binary n) =>-} Binary (TT Name) where put x- = case x of+ = {-# SCC "putTT" #-} + case x of P x1 x2 x3 -> do putWord8 0 put x1 put x2@@ -607,7 +626,8 @@ instance Binary CaseAlt where put x- = case x of+ = {-# SCC "putCaseAlt" #-} + case x of ConCase x1 x2 x3 x4 -> do putWord8 0 put x1 put x2@@ -636,17 +656,16 @@ instance Binary Def where put x- = case x of+ = {-# SCC "putDef" #-} + case x of Function x1 x2 -> do putWord8 0 put x1 put x2 TyDecl x1 x2 -> do putWord8 1 put x1 put x2- Operator x1 x2 x3 -> do putWord8 2- put x1- put x2- put x3+ -- all primitives just get added at the start, don't write+ Operator x1 x2 x3 -> do return () CaseOp x1 x2 x3 x3a x4 x5 x6 x7 x8 -> do putWord8 3 put x1@@ -744,8 +763,9 @@ _ -> error "Corrupted binary data for Totality" instance Binary IBCFile where- put (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23)- = do put x1+ put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24)+ = {-# SCC "putIBCFile" #-} + do put x1 put x2 put x3 put x4@@ -768,6 +788,7 @@ put x21 put x22 put x23+ put x24 get = do x1 <- get if x1 == ibcVersion then @@ -793,7 +814,8 @@ x21 <- get x22 <- get x23 <- get- return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23)+ x24 <- get+ return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24) else return (initIBC { ver = x1 }) instance Binary FnOpt where@@ -1074,6 +1096,15 @@ return (PPostulate x1 x2 x3 x4 x5 x6) _ -> error "Corrupted binary data for PDecl'" +instance Binary Using where+ put (UImplicit x1 x2) = do putWord8 0; put x1; put x2+ put (UConstraint x1 x2) = do putWord8 1; put x1; put x2++ get = do i <- getWord8+ case i of+ 0 -> do x1 <- get; x2 <- get; return (UImplicit x1 x2)+ 1 -> do x1 <- get; x2 <- get; return (UConstraint x1 x2)+ instance Binary SyntaxInfo where put (Syn x1 x2 x3 x4 x5 x6 x7 x8) = do put x1@@ -1257,6 +1288,10 @@ PInferRef x1 x2 -> do putWord8 29 put x1 put x2+ PRewrite x1 x2 x3 -> do putWord8 30+ put x1+ put x2+ put x3 get = do i <- getWord8 case i of@@ -1341,6 +1376,10 @@ 29 -> do x1 <- get x2 <- get return (PInferRef x1 x2)+ 30 -> do x1 <- get+ x2 <- get+ x3 <- get+ return (PRewrite x1 x2 x3) _ -> error "Corrupted binary data for PTerm" instance (Binary t) => Binary (PTactic' t) where@@ -1374,8 +1413,12 @@ put x1 put x2 Qed -> putWord8 15- ReflectTac x1 -> do putWord8 16- put x1+ ApplyTactic x1 -> do putWord8 16+ put x1+ Reflect x1 -> do putWord8 17+ put x1+ Fill x1 -> do putWord8 18+ put x1 get = do i <- getWord8 case i of@@ -1408,7 +1451,11 @@ return (TSeq x1 x2) 15 -> return Qed 16 -> do x1 <- get- return (ReflectTac x1)+ return (ApplyTactic x1)+ 17 -> do x1 <- get+ return (Reflect x1)+ 18 -> do x1 <- get+ return (Fill x1) _ -> error "Corrupted binary data for PTactic'"
+ src/Idris/IdeSlave.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE FlexibleInstances, IncoherentInstances #-}++module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..)) where++import Text.Printf+import Numeric+import Data.List+-- import qualified Data.Text as T+import Text.Parsec++data SExp = SexpList [SExp]+ | StringAtom String+ | BoolAtom Bool+ | IntegerAtom Integer+ | SymbolAtom String+ deriving ( Eq, Show )++sExpToString :: SExp -> String+sExpToString (StringAtom s) = "\"" ++ escape s ++ "\""+sExpToString (BoolAtom True) = ":True"+sExpToString (BoolAtom False) = ":False"+sExpToString (IntegerAtom i) = printf "%d" i+sExpToString (SymbolAtom s) = ":" ++ s+sExpToString (SexpList l) = "(" ++ intercalate " " (map sExpToString l) ++ ")"++class SExpable a where+ toSExp :: a -> SExp++instance SExpable SExp where+ toSExp a = a++instance SExpable Bool where+ toSExp True = BoolAtom True+ toSExp False = BoolAtom False++instance SExpable String where+ toSExp s = StringAtom s++instance SExpable Integer where+ toSExp n = IntegerAtom n++instance SExpable Int where+ toSExp n = IntegerAtom (toInteger n)++instance (SExpable a) => SExpable (Maybe a) where+ toSExp Nothing = SexpList [SymbolAtom "Nothing"]+ toSExp (Just a) = SexpList [SymbolAtom "Just", toSExp a]++instance (SExpable a) => SExpable [a] where+ toSExp l = SexpList (map toSExp l)++instance (SExpable a, SExpable b) => SExpable (a, b) where+ toSExp (l, r) = SexpList [toSExp l, toSExp r]++instance (SExpable a, SExpable b, SExpable c) => SExpable (a, b, c) where+ toSExp (l, m, n) = SexpList [toSExp l, toSExp m, toSExp n]++escape :: String -> String+escape = concatMap escapeChar+ where+ escapeChar '\\' = "\\\\"+ escapeChar '"' = "\\\""+ escapeChar c = [c]++pSExp = do xs <- between (char '(') (char ')') (pSExp `sepBy` (char ' '))+ return (SexpList xs)+ <|> atom++atom = do char ':'; x <- atomC; return x+ <|> do char '"'; xs <- many quotedChar; char '"'; return (StringAtom xs)+ <|> do ints <- many1 digit+ case readDec ints of+ ((num, ""):_) -> return (IntegerAtom (toInteger num))+ _ -> return (StringAtom ints)++atomC = do string "True"; return (BoolAtom True)+ <|> do string "False"; return (BoolAtom False)+ <|> do xs <- many (noneOf " \n\t\r\"()"); return (SymbolAtom xs)++quotedChar = try (string "\\\\" >> return '\\')+ <|> try (string "\\\"" >> return '"')+ <|> noneOf "\""++parseSExp :: String -> Either ParseError SExp+parseSExp = parse pSExp "(unknown)"++data IdeSlaveCommand = REPLCompletions String+ | Interpret String+ | LoadFile String+ deriving Show++sexpToCommand :: SExp -> Maybe IdeSlaveCommand+sexpToCommand (SexpList (x:[])) = sexpToCommand x+sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd)+sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix)+sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename]) = Just (LoadFile filename)+sexpToCommand _ = Nothing++parseMessage :: String -> (SExp, Integer)+parseMessage x = case receiveString x of+ (SexpList [cmd, (IntegerAtom id)]) ->+ (cmd, id)++receiveString :: String -> SExp+receiveString x =+ case readHex (take 6 x) of+ ((num, ""):_) ->+ let msg = drop 6 x in+ if (length msg) /= (num - 1)+ then error "bad input length"+ else (case parseSExp msg of+ Left _ -> error "parse failure"+ Right r -> r)+ _ -> error "readHex failed"++convSExp :: SExpable a => String -> a -> Integer -> String+convSExp pre s id =+ let sex = SexpList [SymbolAtom pre, toSExp s, IntegerAtom id] in+ let str = sExpToString sex in+ (getHexLength str) ++ str++getHexLength :: String -> String+getHexLength s = printf "%06x" (1 + (length s))
src/Idris/Parser.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, ScopedTypeVariables #-} -- | Parse the full Idris language. module Idris.Parser where @@ -11,8 +11,11 @@ import Idris.Coverage import Idris.IBC import Idris.Unlit+import Idris.Providers import Paths_idris +import Util.DynamicLinker+ import Core.CoreParser import Core.TT import Core.Evaluate@@ -27,6 +30,7 @@ import Data.List import Data.List.Split(splitOn) import Control.Monad.State+import Control.Monad.Error import Debug.Trace import Data.Maybe import System.FilePath@@ -213,6 +217,7 @@ closeBlock :: IParser () closeBlock = do ist <- getState bs <- case brace_stack ist of+ [] -> eof >> return [] Nothing : xs -> (lchar '}' >> return xs) <|> (eof >> return []) Just lvl : xs -> (do i <- indent inp <- getInput@@ -269,7 +274,7 @@ pImport :: IParser String pImport = do reserved "import"; f <- identifier; option ';' (lchar ';') return (toPath f)- where toPath n = foldl1 (</>) $ splitOn "." n+ where toPath n = foldl1' (</>) $ splitOn "." n -- | A program is a list of declarations, possibly with associated -- documentation strings.@@ -338,7 +343,8 @@ <|> pClass syn <|> pInstance syn <|> do d <- pDSL syn; return [d]- <|> pDirective+ <|> pDirective syn+ <|> pProvider syn <|> try (do reserved "import"; fp <- identifier fail "imports must be at the top of file") @@ -465,7 +471,7 @@ pUsing :: SyntaxInfo -> IParser [PDecl] pUsing syn = - do reserved "using"; lchar '('; ns <- tyDeclList syn; lchar ')'+ do reserved "using"; lchar '('; ns <- usingDeclList syn; lchar ')' openBlock let uvars = using syn ds <- many1 (pDecl (syn { using = uvars ++ ns }))@@ -542,7 +548,7 @@ acc <- pAccessibility reserved "class"; fc <- pfc; cons <- pConstList syn; n_in <- pName let n = expandNS syn n_in- cs <- many1 carg+ cs <- many carg reserved "where"; openBlock ds <- many $ pFunDecl syn closeBlock@@ -563,7 +569,7 @@ return (Just n)) cs <- pConstList syn cn <- pName- args <- many1 (pSimpleExpr syn)+ args <- many (pSimpleExpr syn) let sc = PApp fc (PRef fc cn) (map pexp args) let t = bindList (PPi constraint) (map (\x -> (MN 0 "c", x)) cs) sc reserved "where"; openBlock @@ -605,9 +611,9 @@ <|> try (pSimpleExpr syn) <|> pLambda syn <|> pLet syn+ <|> pRewriteTerm syn <|> pPi syn <|> pDoBlock syn- <|> pComprehension syn pExtensions :: SyntaxInfo -> [Syntax] -> IParser PTerm pExtensions syn rules = choice (map (try . pExt syn) (filter valid rules))@@ -757,6 +763,7 @@ fc <- pfc return (PInferRef fc x)) <|> try (pList syn)+ <|> try (pComprehension syn) <|> try (pAlt syn) <|> try (pIdiom syn) <|> try (do lchar '('@@ -794,16 +801,30 @@ symbol "=>"; rhs <- pExpr syn return (lhs, rhs) +-- bit of a hack here. If the integer doesn't fit in an Int, treat it as a+-- big integer, otherwise try fromInteger and the constants as alternatives.+-- a better solution would be to fix fromInteger to work with Integer, as the+-- name suggests, rather than Int+ modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm-modifyConst syn fc (PConstant (I x)) +modifyConst syn fc (PConstant (BI x)) + | not (fitsInt x) = PAlternative False + [PConstant (BI x),+ PApp fc (PRef fc (UN "fromInteger"))+ [pexp (PConstant (I (fromInteger x)))]] | not (inPattern syn) = PAlternative False- [PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I x))],- PConstant (I x), PConstant (BI (toEnum x))]+ [PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I (fromInteger x)))],+ PConstant (I (fromInteger x)), PConstant (BI x)] | otherwise = PAlternative False- [PConstant (I x), PConstant (BI (toEnum x))]+ [PConstant (I (fromInteger x)), PConstant (BI x)] modifyConst syn fc x = x +fitsInt :: Integer -> Bool+fitsInt x = let xInt :: Int = fromInteger x+ xInteger :: Integer = toInteger xInt in+ x == xInteger+ pList syn = do lchar '['; fc <- pfc; xs <- sepBy (pExpr syn) (lchar ','); lchar ']' return (mkList fc xs) where@@ -861,7 +882,7 @@ return (dslify i $ PApp fc f args) where dslify i (PApp fc (PRef _ f) [a])- | [d] <- lookupCtxt Nothing f (idris_dsls i)+ | [d] <- lookupCtxt f (idris_dsls i) = desugar (syn { dsl_info = d }) i (getTm a) dslify i t = t @@ -935,6 +956,14 @@ (PCase fc (PRef fc (MN i "lamp")) [(x, pmList xs sc)]) +pRewriteTerm syn = + do reserved "rewrite"+ fc <- pfc+ prf <- pExpr syn+ reserved "in"; sc <- pExpr syn+ return (PRewrite fc + (PApp fc (PRef fc (UN "sym")) [pexp prf]) sc)+ pLet syn = try (do reserved "let"; n <- pName; ty <- option Placeholder (do lchar ':'; pExpr' syn) lchar '='@@ -947,7 +976,9 @@ return (PCase fc v [(pat, sc)])) pPi syn = - try (do lazy <- option False (do lchar '|'; return True)+ try (do lazy <- if implicitAllowed syn -- laziness is top level only+ then option False (do lchar '|'; return True)+ else return False st <- pStatic lchar '('; xt <- tyDeclList syn; lchar ')' doc <- option "" (pDocComment '^')@@ -1001,6 +1032,19 @@ return [t]) <|> return [] +usingDeclList syn + = try (sepBy1 (usingDecl syn) (lchar ','))+ <|> do ns <- sepBy1 pName (lchar ',')+ t <- pTSig (noImp syn)+ return (map (\x -> UImplicit x t) ns)++usingDecl syn = try (do x <- pfName+ t <- pTSig (noImp syn)+ return (UImplicit x t))+ <|> do c <- pfName+ xs <- many1 pfName+ return (UConstraint c xs)+ tyDeclList syn = try (sepBy1 (do x <- pfName t <- pTSig (noImp syn) return (x,t))@@ -1092,8 +1136,7 @@ <|> do reserved "Bits32"; return B32Type <|> do reserved "Bits64"; return B64Type <|> try (do f <- float; return $ Fl f)--- <|> try (do i <- natural; lchar 'L'; return $ BI i)- <|> try (do i <- natural; return $ I (fromInteger i))+ <|> try (do i <- natural; return $ BI i) <|> try (do s <- strlit; return $ Str s) <|> try (do c <- chlit; return $ Ch c) @@ -1334,7 +1377,8 @@ cargs <- many (pConstraintArg syn) iargs <- many (pImplicitArg (syn { inPattern = True } )) fc <- pfc- args <- many (pArgExpr syn)+ args <- many (try (pImplicitArg (syn { inPattern = True } ))+ <|> (fmap pexp (pArgExpr syn))) wargs <- many (pWExpr syn) rhs <- pRHS syn n ist <- getState@@ -1346,7 +1390,7 @@ do pTerminator return ([], [])] let capp = PApp fc (PRef fc n) - (iargs ++ cargs ++ map pexp args)+ (iargs ++ cargs ++ args) ist <- getState setState (ist { lastParse = Just n }) return $ PClause fc n capp wargs rhs wheres)@@ -1372,10 +1416,11 @@ cargs <- many (pConstraintArg syn) iargs <- many (pImplicitArg (syn { inPattern = True } )) fc <- pfc- args <- many (pArgExpr syn)+ args <- many (try (pImplicitArg (syn { inPattern = True } )) + <|> (fmap pexp (pArgExpr syn))) wargs <- many (pWExpr syn) let capp = PApp fc (PRef fc n) - (iargs ++ cargs ++ map pexp args)+ (iargs ++ cargs ++ args) ist <- getState setState (ist { lastParse = Just n }) reserved "with"@@ -1455,35 +1500,51 @@ closeBlock return (concat ds, map (\x -> (x, decoration syn x)) dns) -pDirective :: IParser [PDecl]-pDirective = try (do lchar '%'; reserved "lib"; lib <- strlit;- return [PDirective (do addLib lib- addIBC (IBCLib lib))])- <|> try (do lchar '%'; reserved "link"; obj <- strlit;- return [PDirective (do datadir <- liftIO getDataDir- o <- liftIO $ findInPath [".", datadir] obj- addIBC (IBCObj o)- addObjectFile o)])- <|> try (do lchar '%'; reserved "include"; hdr <- strlit;- return [PDirective (do addHdr hdr- addIBC (IBCHeader hdr))])- <|> try (do lchar '%'; reserved "hide"; n <- iName []- return [PDirective (do setAccessibility n Hidden- addIBC (IBCAccess n Hidden))])- <|> try (do lchar '%'; reserved "freeze"; n <- iName []- return [PDirective (do setAccessibility n Frozen- addIBC (IBCAccess n Frozen))])- <|> try (do lchar '%'; reserved "access"; acc <- pAccessibility'- return [PDirective (do i <- getIState- putIState (i { default_access = acc }))])- <|> try (do lchar '%'; reserved "default"; tot <- pTotality- i <- getState- setState (i { default_total = tot } )- return [PDirective (do i <- getIState- putIState (i { default_total = tot }))])- <|> try (do lchar '%'; reserved "logging"; i <- natural;- return [PDirective (setLogLevel (fromInteger i))])+pDirective :: SyntaxInfo -> IParser [PDecl]+pDirective syn = try (do lchar '%'; reserved "lib"; lib <- strlit;+ return [PDirective (do addLib lib+ addIBC (IBCLib lib))])+ <|> try (do lchar '%'; reserved "link"; obj <- strlit;+ return [PDirective (do datadir <- liftIO getDataDir+ o <- liftIO $ findInPath [".", datadir] obj+ addIBC (IBCObj o)+ addObjectFile o)])+ <|> try (do lchar '%'; reserved "include"; hdr <- strlit;+ return [PDirective (do addHdr hdr+ addIBC (IBCHeader hdr))])+ <|> try (do lchar '%'; reserved "hide"; n <- iName []+ return [PDirective (do setAccessibility n Hidden+ addIBC (IBCAccess n Hidden))])+ <|> try (do lchar '%'; reserved "freeze"; n <- iName []+ return [PDirective (do setAccessibility n Frozen+ addIBC (IBCAccess n Frozen))])+ <|> try (do lchar '%'; reserved "access"; acc <- pAccessibility'+ return [PDirective (do i <- getIState+ putIState (i { default_access = acc }))])+ <|> try (do lchar '%'; reserved "default"; tot <- pTotality+ i <- getState+ setState (i { default_total = tot } )+ return [PDirective (do i <- getIState+ putIState (i { default_total = tot }))])+ <|> try (do lchar '%'; reserved "logging"; i <- natural;+ return [PDirective (setLogLevel (fromInteger i))])+ <|> try (do lchar '%'; reserved "dynamic"; libs <- sepBy1 strlit (lchar ',');+ return [PDirective (do added <- addDyLib libs+ case added of+ Left lib -> addIBC (IBCDyLib (lib_name lib))+ Right msg ->+ fail $ msg)])+ <|> try (do lchar '%'; reserved "language"; ext <- reserved "TypeProviders";+ return [PDirective (addLangExt TypeProviders)]) +pProvider :: SyntaxInfo -> IParser [PDecl]+pProvider syn = do lchar '%'; reserved "provide";+ lchar '('; n <- pfName; t <- pTSig syn; lchar ')'+ fc <- pfc+ reserved "with"+ e <- pExpr syn+ return [PProvider syn fc n t e]+ pTactic :: SyntaxInfo -> IParser PTactic pTactic syn = do reserved "intro"; ns <- sepBy pName (lchar ',') return $ Intro ns@@ -1510,9 +1571,15 @@ <|> do reserved "exact"; t <- pExpr syn; i <- getState return $ Exact (desugar syn i t)+ <|> do reserved "applyTactic"; t <- pExpr syn;+ i <- getState+ return $ ApplyTactic (desugar syn i t) <|> do reserved "reflect"; t <- pExpr syn; i <- getState- return $ ReflectTac (desugar syn i t)+ return $ Reflect (desugar syn i t)+ <|> do reserved "fill"; t <- pExpr syn;+ i <- getState+ return $ Fill (desugar syn i t) <|> do reserved "try"; t <- pTactic syn; lchar '|'; t1 <- pTactic syn
src/Idris/Primitives.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes, ScopedTypeVariables, PatternGuards #-} module Idris.Primitives(elabPrims) where @@ -34,280 +34,73 @@ primitives = -- operators- [Prim (UN "prim__addInt") (ty [IType, IType] IType) 2 (iBin (+))- (2, LPlus) total,- Prim (UN "prim__subInt") (ty [IType, IType] IType) 2 (iBin (-))- (2, LMinus) total,- Prim (UN "prim__mulInt") (ty [IType, IType] IType) 2 (iBin (*))- (2, LTimes) total,- Prim (UN "prim__divInt") (ty [IType, IType] IType) 2 (iBin div)- (2, LDiv) partial,- Prim (UN "prim__modInt") (ty [IType, IType] IType) 2 (iBin mod)- (2, LMod) partial,- Prim (UN "prim__andInt") (ty [IType, IType] IType) 2 (iBin (.&.))- (2, LAnd) partial,- Prim (UN "prim__orInt") (ty [IType, IType] IType) 2 (iBin (.|.))- (2, LOr) partial,- Prim (UN "prim__xorInt") (ty [IType, IType] IType) 2 (iBin xor)- (2, LXOr) partial,- Prim (UN "prim__shLInt") (ty [IType, IType] IType) 2 (iBin shiftL)- (2, LSHL) partial,- Prim (UN "prim__shRInt") (ty [IType, IType] IType) 2 (iBin shiftR)- (2, LSHR) partial,- Prim (UN "prim__complInt") (ty [IType] IType) 1 (iUn complement)- (1, LCompl) partial,- Prim (UN "prim__eqInt") (ty [IType, IType] IType) 2 (biBin (==))- (2, LEq) total,- Prim (UN "prim__ltInt") (ty [IType, IType] IType) 2 (biBin (<))- (2, LLt) total,- Prim (UN "prim__lteInt") (ty [IType, IType] IType) 2 (biBin (<=))- (2, LLe) total,- Prim (UN "prim__gtInt") (ty [IType, IType] IType) 2 (biBin (>))- (2, LGt) total,- Prim (UN "prim__gteInt") (ty [IType, IType] IType) 2 (biBin (>=))- (2, LGe) total,- Prim (UN "prim__eqChar") (ty [ChType, ChType] IType) 2 (bcBin (==))- (2, LEq) total,+ [Prim (UN "prim__eqChar") (ty [ChType, ChType] IType) 2 (bcBin (==))+ (2, LEq ITNative) total, Prim (UN "prim__ltChar") (ty [ChType, ChType] IType) 2 (bcBin (<))- (2, LLt) total,+ (2, LLt ITNative) total, Prim (UN "prim__lteChar") (ty [ChType, ChType] IType) 2 (bcBin (<=))- (2, LLe) total,+ (2, LLe ITNative) total, Prim (UN "prim__gtChar") (ty [ChType, ChType] IType) 2 (bcBin (>))- (2, LGt) total,+ (2, LGt ITNative) total, Prim (UN "prim__gteChar") (ty [ChType, ChType] IType) 2 (bcBin (>=))- (2, LGe) total,-- Prim (UN "prim__ltB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (<))- (2, LB8Lt) total,- Prim (UN "prim__lteB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (<=))- (2, LB8Lte) total,- Prim (UN "prim__eqB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (==))- (2, LB8Eq) total,- Prim (UN "prim__gteB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (>))- (2, LB8Gte) total,- Prim (UN "prim__gtB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (>=))- (2, LB8Gt) total,- Prim (UN "prim__addB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (+))- (2, LB8Plus) total,- Prim (UN "prim__subB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (-))- (2, LB8Minus) total,- Prim (UN "prim__mulB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (*))- (2, LB8Times) total,- Prim (UN "prim__udivB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin div)- (2, LB8UDiv) partial,- Prim (UN "prim__sdivB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin s8div)- (2, LB8SDiv) partial,- Prim (UN "prim__uremB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin rem)- (2, LB8URem) partial,- Prim (UN "prim__sremB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin s8rem)- (2, LB8SRem) partial,- Prim (UN "prim__shlB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (\x y -> shiftL x (fromIntegral y)))- (2, LB8Shl) total,- Prim (UN "prim__lshrB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (\x y -> shiftR x (fromIntegral y)))- (2, LB8AShr) total,- Prim (UN "prim__ashrB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (\x y -> fromIntegral $- shiftR (fromIntegral x :: Int8)- (fromIntegral y)))- (2, LB8LShr) total,- Prim (UN "prim__andB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (.&.))- (2, LB8And) total,- Prim (UN "prim__orB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (.|.))- (2, LB8Or) total,- Prim (UN "prim__xorB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin xor)- (2, LB8Xor) total,- Prim (UN "prim__complB8") (ty [B8Type] B8Type) 1 (b8Un complement)- (1, LB8Compl) total,- Prim (UN "prim__zextB8_16") (ty [B8Type] B16Type) 1 zext8_16- (1, LB8Z16) total,- Prim (UN "prim__zextB8_32") (ty [B8Type] B32Type) 1 zext8_32- (1, LB8Z32) total,- Prim (UN "prim__zextB8_64") (ty [B8Type] B64Type) 1 zext8_64- (1, LB8Z64) total,- Prim (UN "prim__sextB8_16") (ty [B8Type] B16Type) 1 sext8_16- (1, LB8Z16) total,- Prim (UN "prim__sextB8_32") (ty [B8Type] B32Type) 1 sext8_32- (1, LB8Z32) total,- Prim (UN "prim__sextB8_64") (ty [B8Type] B64Type) 1 sext8_64- (1, LB8Z64) total,-- Prim (UN "prim__ltB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (<))- (2, LB16Lt) total,- Prim (UN "prim__lteB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (<=))- (2, LB16Lte) total,- Prim (UN "prim__eqB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (==))- (2, LB16Eq) total,- Prim (UN "prim__gteB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (>))- (2, LB16Gte) total,- Prim (UN "prim__gtB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (>=))- (2, LB16Gt) total,- Prim (UN "prim__addB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (+))- (2, LB16Plus) total,- Prim (UN "prim__subB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (-))- (2, LB16Minus) total,- Prim (UN "prim__mulB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (*))- (2, LB16Times) total,- Prim (UN "prim__udivB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin div)- (2, LB16UDiv) partial,- Prim (UN "prim__sdivB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin s16div)- (2, LB16SDiv) partial,- Prim (UN "prim__uremB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin rem)- (2, LB16URem) partial,- Prim (UN "prim__sremB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin s16rem)- (2, LB16SRem) partial,- Prim (UN "prim__shlB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (\x y -> shiftL x (fromIntegral y)))- (2, LB16Shl) total,- Prim (UN "prim__lshrB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (\x y -> shiftR x (fromIntegral y)))- (2, LB16AShr) total,- Prim (UN "prim__ashrB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (\x y -> fromIntegral $- shiftR (fromIntegral x :: Int16)- (fromIntegral y)))- (2, LB16LShr) total,- Prim (UN "prim__andB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (.&.))- (2, LB16And) total,- Prim (UN "prim__orB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (.|.))- (2, LB16Or) total,- Prim (UN "prim__xorB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin xor)- (2, LB16Xor) total,- Prim (UN "prim__complB16") (ty [B16Type] B16Type) 1 (b16Un complement)- (1, LB16Compl) total,- Prim (UN "prim__zextB16_32") (ty [B16Type] B32Type) 1 zext16_32- (1, LB16Z32) total,- Prim (UN "prim__zextB16_64") (ty [B16Type] B64Type) 1 zext16_64- (1, LB16Z64) total,- Prim (UN "prim__sextB16_32") (ty [B16Type] B32Type) 1 sext16_32- (1, LB16Z32) total,- Prim (UN "prim__sextB16_64") (ty [B16Type] B64Type) 1 sext16_64- (1, LB16Z64) total,- Prim (UN "prim__truncB16_8") (ty [B16Type] B8Type) 1 trunc16_8- (1, LB16T8) total,+ (2, LGe ITNative) total, - Prim (UN "prim__ltB32") (ty [B32Type, B32Type] IType) 2 (b32Cmp (<))- (2, LB32Lt) total,- Prim (UN "prim__lteB32") (ty [B32Type, B32Type] IType) 2 (b32Cmp (<=))- (2, LB32Lte) total,- Prim (UN "prim__eqB32") (ty [B32Type, B32Type] IType) 2 (b32Cmp (==))- (2, LB32Eq) total,- Prim (UN "prim__gteB32") (ty [B32Type, B32Type] IType) 2 (b32Cmp (>))- (2, LB32Gte) total,- Prim (UN "prim__gtB32") (ty [B32Type, B32Type] IType) 2 (b32Cmp (>=))- (2, LB32Gt) total,- Prim (UN "prim__addB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (+))- (2, LB32Plus) total,- Prim (UN "prim__subB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (-))- (2, LB32Minus) total,- Prim (UN "prim__mulB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (*))- (2, LB32Times) total,- Prim (UN "prim__udivB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin div)- (2, LB32UDiv) partial,- Prim (UN "prim__sdivB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin s32div)- (2, LB32SDiv) partial,- Prim (UN "prim__uremB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin rem)- (2, LB32URem) partial,- Prim (UN "prim__sremB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin s32rem)- (2, LB32SRem) partial,- Prim (UN "prim__shlB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (\x y -> shiftL x (fromIntegral y)))- (2, LB32Shl) total,- Prim (UN "prim__lshrB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (\x y -> shiftR x (fromIntegral y)))- (2, LB32AShr) total,- Prim (UN "prim__ashrB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (\x y -> fromIntegral $- shiftR (fromIntegral x :: Int32)- (fromIntegral y)))- (2, LB32LShr) total,- Prim (UN "prim__andB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (.&.))- (2, LB32And) total,- Prim (UN "prim__orB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (.|.))- (2, LB32Or) total,- Prim (UN "prim__xorB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin xor)- (2, LB32Xor) total,- Prim (UN "prim__complB32") (ty [B32Type] B32Type) 1 (b32Un complement)- (1, LB32Compl) total,- Prim (UN "prim__zextB32_64") (ty [B32Type] B64Type) 1 zext32_64- (1, LB32Z64) total,- Prim (UN "prim__sextB32_64") (ty [B32Type] B64Type) 1 sext32_64- (1, LB32Z64) total,- Prim (UN "prim__truncB32_8") (ty [B32Type] B8Type) 1 trunc32_8- (1, LB32T8) total,- Prim (UN "prim__truncB32_16") (ty [B32Type] B16Type) 1 trunc32_16- (1, LB32T16) total,+ iCoerce IT8 IT16 "zext" zext LZExt,+ iCoerce IT8 IT32 "zext" zext LZExt,+ iCoerce IT8 IT64 "zext" zext LZExt,+ iCoerce IT8 ITBig "zext" zext LZExt,+ iCoerce IT8 ITNative "zext" zext LZExt,+ iCoerce IT16 IT32 "zext" zext LZExt,+ iCoerce IT16 IT64 "zext" zext LZExt,+ iCoerce IT16 ITBig "zext" zext LZExt,+ iCoerce IT16 ITNative "zext" zext LZExt,+ iCoerce IT32 IT64 "zext" zext LZExt,+ iCoerce IT32 ITBig "zext" zext LZExt,+ iCoerce IT32 ITNative "zext" zext LZExt,+ iCoerce IT64 ITBig "zext" zext LZExt,+ iCoerce ITNative ITBig "zext" zext LZExt,+ iCoerce ITNative IT64 "zext" zext LZExt,+ iCoerce ITNative IT32 "zext" zext LZExt,+ iCoerce ITNative IT16 "zext" zext LZExt, - Prim (UN "prim__ltB64") (ty [B64Type, B64Type] IType) 2 (b64Cmp (<))- (2, LB64Lt) total,- Prim (UN "prim__lteB64") (ty [B64Type, B64Type] IType) 2 (b64Cmp (<=))- (2, LB64Lte) total,- Prim (UN "prim__eqB64") (ty [B64Type, B64Type] IType) 2 (b64Cmp (==))- (2, LB64Eq) total,- Prim (UN "prim__gteB64") (ty [B64Type, B64Type] IType) 2 (b64Cmp (>))- (2, LB64Gte) total,- Prim (UN "prim__gtB64") (ty [B64Type, B64Type] IType) 2 (b64Cmp (>=))- (2, LB64Gt) total,- Prim (UN "prim__addB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (+))- (2, LB64Plus) total,- Prim (UN "prim__subB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (-))- (2, LB64Minus) total,- Prim (UN "prim__mulB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (*))- (2, LB64Times) total,- Prim (UN "prim__udivB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin div)- (2, LB64UDiv) partial,- Prim (UN "prim__sdivB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin s64div)- (2, LB64SDiv) partial,- Prim (UN "prim__uremB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin rem)- (2, LB64URem) partial,- Prim (UN "prim__sremB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin s64rem)- (2, LB64SRem) partial,- Prim (UN "prim__shlB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (\x y -> shiftL x (fromIntegral y)))- (2, LB64Shl) total,- Prim (UN "prim__lshrB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (\x y -> shiftR x (fromIntegral y)))- (2, LB64AShr) total,- Prim (UN "prim__ashrB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (\x y -> fromIntegral $- shiftR (fromIntegral x :: Int64)- (fromIntegral y)))- (2, LB64LShr) total,- Prim (UN "prim__andB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (.&.))- (2, LB64And) total,- Prim (UN "prim__orB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (.|.))- (2, LB64Or) total,- Prim (UN "prim__xorB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin xor)- (2, LB64Xor) total,- Prim (UN "prim__complB64") (ty [B64Type] B64Type) 1 (b64Un complement)- (1, LB64Compl) total,- Prim (UN "prim__truncB64_8") (ty [B64Type] B8Type) 1 trunc64_8- (1, LB64T8) total,- Prim (UN "prim__truncB64_16") (ty [B64Type] B16Type) 1 trunc64_16- (1, LB64T16) total,- Prim (UN "prim__truncB64_32") (ty [B64Type] B32Type) 1 trunc64_32- (1, LB64T32) total,+ iCoerce IT8 IT16 "sext" sext LSExt,+ iCoerce IT8 IT32 "sext" sext LSExt,+ iCoerce IT8 IT64 "sext" sext LSExt,+ iCoerce IT8 ITBig "sext" sext LSExt,+ iCoerce IT8 ITNative "sext" sext LSExt,+ iCoerce IT16 IT32 "sext" sext LSExt,+ iCoerce IT16 IT64 "sext" sext LSExt,+ iCoerce IT16 ITBig "sext" sext LSExt,+ iCoerce IT16 ITNative "sext" sext LSExt,+ iCoerce IT32 IT64 "sext" sext LSExt,+ iCoerce IT32 ITBig "sext" sext LSExt,+ iCoerce IT32 ITNative "sext" sext LSExt,+ iCoerce IT64 ITBig "sext" sext LSExt,+ iCoerce ITNative ITBig "sext" sext LSExt,+ iCoerce ITNative ITBig "sext" sext LSExt,+ iCoerce ITNative IT64 "sext" sext LSExt,+ iCoerce ITNative IT32 "sext" sext LSExt,+ iCoerce ITNative IT16 "sext" sext LSExt, - Prim (UN "prim__intToB8") (ty [IType] B8Type) 1 intToBits8- (1, LIntB8) total,- Prim (UN "prim__intToB16") (ty [IType] B16Type) 1 intToBits16- (1, LIntB16) total,- Prim (UN "prim__intToB32") (ty [IType] B32Type) 1 intToBits32- (1, LIntB32) total,- Prim (UN "prim__intToB64") (ty [IType] B64Type) 1 intToBits64- (1, LIntB64) total,- Prim (UN "prim__B32ToInt") (ty [B32Type] IType) 1 bits32ToInt- (1, LB32Int) total,+ iCoerce IT16 IT8 "trunc" trunc LTrunc,+ iCoerce IT32 IT8 "trunc" trunc LTrunc,+ iCoerce IT64 IT8 "trunc" trunc LTrunc,+ iCoerce ITBig IT8 "trunc" trunc LTrunc,+ iCoerce ITNative IT8 "trunc" trunc LTrunc,+ iCoerce IT32 IT16 "trunc" trunc LTrunc,+ iCoerce IT64 IT16 "trunc" trunc LTrunc,+ iCoerce ITBig IT16 "trunc" trunc LTrunc,+ iCoerce ITNative IT16 "trunc" trunc LTrunc,+ iCoerce IT64 IT32 "trunc" trunc LTrunc,+ iCoerce ITBig IT32 "trunc" trunc LTrunc,+ iCoerce ITNative IT32 "trunc" trunc LTrunc,+ iCoerce ITBig IT64 "trunc" trunc LTrunc,+ iCoerce IT16 ITNative "trunc" trunc LTrunc,+ iCoerce IT32 ITNative "trunc" trunc LTrunc,+ iCoerce IT64 ITNative "trunc" trunc LTrunc,+ iCoerce ITBig ITNative "trunc" trunc LTrunc,+ iCoerce ITNative IT64 "trunc" trunc LTrunc, - Prim (UN "prim__addBigInt") (ty [BIType, BIType] BIType) 2 (bBin (+))- (2, LBPlus) total,- Prim (UN "prim__subBigInt") (ty [BIType, BIType] BIType) 2 (bBin (-))- (2, LBMinus) total,- Prim (UN "prim__mulBigInt") (ty [BIType, BIType] BIType) 2 (bBin (*))- (2, LBTimes) total,- Prim (UN "prim__divBigInt") (ty [BIType, BIType] BIType) 2 (bBin div)- (2, LBDiv) partial,- Prim (UN "prim__modBigInt") (ty [BIType, BIType] BIType) 2 (bBin mod)- (2, LBMod) partial,- Prim (UN "prim__eqBigInt") (ty [BIType, BIType] IType) 2 (bbBin (==))- (2, LBEq) total,- Prim (UN "prim__ltBigInt") (ty [BIType, BIType] IType) 2 (bbBin (<))- (2, LBLt) total,- Prim (UN "prim__lteBigInt") (ty [BIType, BIType] IType) 2 (bbBin (<=))- (2, LBLe) total,- Prim (UN "prim__gtBigInt") (ty [BIType, BIType] IType) 2 (bbBin (>))- (2, LBGt) total,- Prim (UN "prim__gtBigInt") (ty [BIType, BIType] IType) 2 (bbBin (>=))- (2, LBGe) total, Prim (UN "prim__addFloat") (ty [FlType, FlType] FlType) 2 (fBin (+)) (2, LFPlus) total, Prim (UN "prim__subFloat") (ty [FlType, FlType] FlType) 2 (fBin (-))@@ -332,31 +125,17 @@ (2, LStrEq) total, Prim (UN "prim__ltString") (ty [StrType, StrType] IType) 2 (bsBin (<)) (2, LStrLt) total,+ Prim (UN "prim_lenString") (ty [StrType] IType) 1 (p_strLen)+ (1, LStrLen) total, -- Conversions- Prim (UN "prim__strToInt") (ty [StrType] IType) 1 (c_strToInt)- (1, LStrInt) total,- Prim (UN "prim__intToStr") (ty [IType] StrType) 1 (c_intToStr)- (1, LIntStr) total, Prim (UN "prim__charToInt") (ty [ChType] IType) 1 (c_charToInt)- (1, LChInt) total,+ (1, LChInt ITNative) total, Prim (UN "prim__intToChar") (ty [IType] ChType) 1 (c_intToChar)- (1, LIntCh) total,- Prim (UN "prim__intToBigInt") (ty [IType] BIType) 1 (c_intToBigInt)- (1, LIntBig) total,- Prim (UN "prim__bigIntToInt") (ty [BIType] IType) 1 (c_bigIntToInt)- (1, LBigInt) total,- Prim (UN "prim__strToBigInt") (ty [StrType] BIType) 1 (c_strToBigInt)- (1, LStrBig) total,- Prim (UN "prim__bigIntToStr") (ty [BIType] StrType) 1 (c_bigIntToStr)- (1, LBigStr) total,+ (1, LIntCh ITNative) total, Prim (UN "prim__strToFloat") (ty [StrType] FlType) 1 (c_strToFloat) (1, LStrFloat) total, Prim (UN "prim__floatToStr") (ty [FlType] StrType) 1 (c_floatToStr) (1, LFloatStr) total,- Prim (UN "prim__intToFloat") (ty [IType] FlType) 1 (c_intToFloat)- (1, LIntFloat) total,- Prim (UN "prim__floatToInt") (ty [FlType] IType) 1 (c_floatToInt)- (1, LFloatInt) total, Prim (UN "prim__floatExp") (ty [FlType] FlType) 1 (p_floatExp) (1, LFExp) total, @@ -400,8 +179,50 @@ (0, LStdIn) partial, Prim (UN "prim__believe_me") believeTy 3 (p_believeMe) (3, LNoOp) partial -- ahem- ]+ ] ++ concatMap intOps [IT8, IT16, IT32, IT64, ITBig, ITNative] +intOps ity =+ [ iCmp ity "lt" (bCmp ity (<)) LLt total+ , iCmp ity "lte" (bCmp ity (<=)) LLe total+ , iCmp ity "eq" (bCmp ity (==)) LEq total+ , iCmp ity "gte" (bCmp ity (>=)) LGe total+ , iCmp ity "gt" (bCmp ity (>)) LGt total+ , iBinOp ity "add" (bitBin ity (+)) LPlus total+ , iBinOp ity "sub" (bitBin ity (-)) LMinus total+ , iBinOp ity "mul" (bitBin ity (*)) LTimes total+ , iBinOp ity "udiv" (bitBin ity div) LUDiv partial+ , iBinOp ity "sdiv" (bsdiv ity) LSDiv partial+ , iBinOp ity "urem" (bitBin ity rem) LURem partial+ , iBinOp ity "srem" (bsrem ity) LSRem partial+ , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total+ , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total+ , iBinOp ity "ashr" (bashr ity) LASHR total+ , iBinOp ity "and" (bitBin ity (.&.)) LAnd total+ , iBinOp ity "or" (bitBin ity (.|.)) LOr total+ , iBinOp ity "xor" (bitBin ity (xor)) LXOr total+ , iUnOp ity "compl" (bUn ity complement) LCompl total+ , Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [intTyToConst ity] StrType) 1 intToStr+ (1, LIntStr ity) total+ , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (intTyToConst ity)) 1 (strToInt ity)+ (1, LStrInt ity) total+ , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [intTyToConst ity] FlType) 1 intToFloat+ (1, LIntFloat ity) total+ , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [FlType] (intTyToConst ity)) 1 (floatToInt ity)+ (1, LFloatInt ity) total+ ]++intTyName :: IntTy -> String+intTyName ITNative = "Int"+intTyName ITBig = "BigInt"+intTyName sized = "B" ++ show (intTyWidth sized)++iCmp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty (replicate 2 $ intTyToConst ity) IType) 2 impl (2, irop ity) totality+iBinOp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty (replicate 2 $ intTyToConst ity) (intTyToConst ity)) 2 impl (2, irop ity) totality+iUnOp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty [intTyToConst ity] (intTyToConst ity)) 1 impl (1, irop ity) totality+iCoerce from to op impl irop =+ Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)+ (ty [intTyToConst from] (intTyToConst to)) 1 (impl from to) (1, irop from to) total+ p_believeMe [_,_,x] = Just x p_believeMe _ = Nothing @@ -439,161 +260,127 @@ sBin op [VConstant (Str x), VConstant (Str y)] = Just $ VConstant (Str (op x y)) sBin _ _ = Nothing -s8div :: Word8 -> Word8 -> Word8-s8div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int8)--s16div :: Word16 -> Word16 -> Word16-s16div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int16)--s32div :: Word32 -> Word32 -> Word32-s32div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int32)--s64div :: Word64 -> Word64 -> Word64-s64div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int64)--s8rem :: Word8 -> Word8 -> Word8-s8rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8)--s16rem :: Word16 -> Word16 -> Word16-s16rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16)--s32rem :: Word32 -> Word32 -> Word32-s32rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32)--s64rem :: Word64 -> Word64 -> Word64-s64rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64)--b8Bin op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (B8 (op x y))-b8Bin _ _ = Nothing--b8Un op [VConstant (B8 x)] = Just $ VConstant (B8 (op x))-b8Un _ _ = Nothing--b16Bin op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (B16 (op x y))-b16Bin _ _ = Nothing--b16Un op [VConstant (B16 x)] = Just $ VConstant (B16 (op x))-b16Un _ _ = Nothing--b32Bin op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (B32 (op x y))-b32Bin _ _ = Nothing--b32Un op [VConstant (B32 x)] = Just $ VConstant (B32 (op x))-b32Un _ _ = Nothing--b64Bin op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (B64 (op x y))-b64Bin _ _ = Nothing--b64Un op [VConstant (B64 x)] = Just $ VConstant (B64 (op x))-b64Un _ _ = Nothing--b8Cmp op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))-b8Cmp _ _ = Nothing--b16Cmp op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))-b16Cmp _ _ = Nothing--b32Cmp op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))-b32Cmp _ _ = Nothing--b64Cmp op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))-b64Cmp _ _ = Nothing--toB8 x = VConstant (B8 (fromIntegral x))-toB16 x = VConstant (B16 (fromIntegral x))-toB32 x = VConstant (B32 (fromIntegral x))-toB64 x = VConstant (B64 (fromIntegral x))--zext8_16 [VConstant (B8 x)] = Just $ toB16 x-zext8_16 _ = Nothing--zext8_32 [VConstant (B8 x)] = Just $ toB32 x-zext8_32 _ = Nothing--zext8_64 [VConstant (B8 x)] = Just $ toB64 x-zext8_64 _ = Nothing--sext8_16 [VConstant (B8 x)] = Just $ toB16 (fromIntegral x :: Int8)-sext8_16 _ = Nothing--sext8_32 [VConstant (B8 x)] = Just $ toB32 (fromIntegral x :: Int8)-sext8_32 _ = Nothing--sext8_64 [VConstant (B8 x)] = Just $ toB64 (fromIntegral x :: Int8)-sext8_64 _ = Nothing+bsrem IT8 [VConstant (B8 x), VConstant (B8 y)]+ = Just $ VConstant (B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8)))+bsrem IT16 [VConstant (B16 x), VConstant (B16 y)]+ = Just $ VConstant (B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16)))+bsrem IT32 [VConstant (B32 x), VConstant (B32 y)]+ = Just $ VConstant (B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32)))+bsrem IT64 [VConstant (B64 x), VConstant (B64 y)]+ = Just $ VConstant (B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64)))+bsrem ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `rem` y))+bsrem _ _ = Nothing -zext16_32 [VConstant (B16 x)] = Just $ toB32 x-zext16_32 _ = Nothing+bsdiv IT8 [VConstant (B8 x), VConstant (B8 y)]+ = Just $ VConstant (B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8)))+bsdiv IT16 [VConstant (B16 x), VConstant (B16 y)]+ = Just $ VConstant (B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16)))+bsdiv IT32 [VConstant (B32 x), VConstant (B32 y)]+ = Just $ VConstant (B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32)))+bsdiv IT64 [VConstant (B64 x), VConstant (B64 y)]+ = Just $ VConstant (B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64)))+bsdiv ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `div` y))+bsdiv _ _ = Nothing -zext16_64 [VConstant (B16 x)] = Just $ toB64 x-zext16_64 _ = Nothing+bashr IT8 [VConstant (B8 x), VConstant (B8 y)]+ = Just $ VConstant (B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8)))+bashr IT16 [VConstant (B16 x), VConstant (B16 y)]+ = Just $ VConstant (B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16)))+bashr IT32 [VConstant (B32 x), VConstant (B32 y)]+ = Just $ VConstant (B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32)))+bashr IT64 [VConstant (B64 x), VConstant (B64 y)]+ = Just $ VConstant (B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64)))+bashr ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `shiftR` y))+bashr _ _ = Nothing -sext16_32 [VConstant (B16 x)] = Just $ toB32 (fromIntegral x :: Int16)-sext16_32 _ = Nothing+bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Value] -> Maybe Value+bUn IT8 op [VConstant (B8 x)] = Just $ VConstant (B8 (op x))+bUn IT16 op [VConstant (B16 x)] = Just $ VConstant (B16 (op x))+bUn IT32 op [VConstant (B32 x)] = Just $ VConstant (B32 (op x))+bUn IT64 op [VConstant (B64 x)] = Just $ VConstant (B64 (op x))+bUn ITBig op [VConstant (BI x)] = Just $ VConstant (BI (op x))+bUn ITNative op [VConstant (I x)] = Just $ VConstant (I (op x))+bUn _ _ _ = Nothing -sext16_64 [VConstant (B16 x)] = Just $ toB64 (fromIntegral x :: Int16)-sext16_64 _ = Nothing+bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Value] -> Maybe Value+bitBin IT8 op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (B8 (op x y))+bitBin IT16 op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (B16 (op x y))+bitBin IT32 op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (B32 (op x y))+bitBin IT64 op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (B64 (op x y))+bitBin ITBig op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (BI (op x y))+bitBin ITNative op [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (op x y))+bitBin _ _ _ = Nothing -trunc16_8 [VConstant (B16 x)] = Just $ toB8 x-trunc16_8 _ = Nothing+bCmp :: IntTy -> (forall a. Ord a => a -> a -> Bool) -> [Value] -> Maybe Value+bCmp IT8 op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))+bCmp IT16 op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))+bCmp IT32 op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))+bCmp IT64 op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))+bCmp ITBig op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (I (if (op x y) then 1 else 0))+bCmp ITNative op [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (if (op x y) then 1 else 0))+bCmp _ _ _ = Nothing -zext32_64 [VConstant (B32 x)] = Just $ toB64 x-zext32_64 _ = Nothing+toInt IT8 x = VConstant (B8 (fromIntegral x))+toInt IT16 x = VConstant (B16 (fromIntegral x))+toInt IT32 x = VConstant (B32 (fromIntegral x))+toInt IT64 x = VConstant (B64 (fromIntegral x))+toInt ITBig x = VConstant (BI (fromIntegral x))+toInt ITNative x = VConstant (I (fromIntegral x)) -sext32_64 [VConstant (B32 x)] = Just $ toB64 (fromIntegral x :: Int32)-sext32_64 _ = Nothing+intToInt IT8 out [VConstant (B8 x)] = Just $ toInt out x+intToInt IT16 out [VConstant (B16 x)] = Just $ toInt out x+intToInt IT32 out [VConstant (B32 x)] = Just $ toInt out x+intToInt IT64 out [VConstant (B64 x)] = Just $ toInt out x+intToInt ITBig out [VConstant (BI x)] = Just $ toInt out x+intToInt ITNative out [VConstant (I x)] = Just $ toInt out x+intToInt _ _ _ = Nothing -trunc32_8 [VConstant (B32 x)] = Just $ toB8 x-trunc32_8 _ = Nothing+zext from ITBig val = intToInt from ITBig val+zext ITBig _ _ = Nothing+zext from to val+ | intTyWidth from < intTyWidth to = intToInt from to val+zext _ _ _ = Nothing -trunc32_16 [VConstant (B32 x)] = Just $ toB16 x-trunc32_16 _ = Nothing+sext IT8 out [VConstant (B8 x)] = Just $ toInt out (fromIntegral x :: Int8)+sext IT16 out [VConstant (B16 x)] = Just $ toInt out (fromIntegral x :: Int16)+sext IT32 out [VConstant (B32 x)] = Just $ toInt out (fromIntegral x :: Int32)+sext IT64 out [VConstant (B64 x)] = Just $ toInt out (fromIntegral x :: Int64)+sext ITBig _ _ = Nothing+sext from to val = intToInt from to val -trunc64_8 [VConstant (B64 x)] = Just $ toB8 x-trunc64_8 _ = Nothing+trunc ITBig to val = intToInt ITBig to val+trunc _ ITBig _ = Nothing+trunc from to val | intTyWidth from > intTyWidth to = intToInt from to val+trunc _ _ _ = Nothing -trunc64_16 [VConstant (B64 x)] = Just $ toB16 x-trunc64_16 _ = Nothing+getInt :: [Value] -> Maybe Integer+getInt [VConstant (B8 x)] = Just . toInteger $ x+getInt [VConstant (B16 x)] = Just . toInteger $ x+getInt [VConstant (B32 x)] = Just . toInteger $ x+getInt [VConstant (B64 x)] = Just . toInteger $ x+getInt [VConstant (I x)] = Just . toInteger $ x+getInt [VConstant (BI x)] = Just x+getInt _ = Nothing -trunc64_32 [VConstant (B64 x)] = Just $ toB32 x-trunc64_32 _ = Nothing+intToStr val | Just i <- getInt val = Just $ VConstant (Str (show i))+intToStr _ = Nothing -intToBits8 [VConstant (I x)] = Just $ toB8 x-intToBits8 _ = Nothing-intToBits16 [VConstant (I x)] = Just $ toB16 x-intToBits16 _ = Nothing-intToBits32 [VConstant (I x)] = Just $ toB32 x-intToBits32 _ = Nothing-intToBits64 [VConstant (I x)] = Just $ toB64 x-intToBits64 _ = Nothing+strToInt ity [VConstant (Str x)] = case reads x of+ [(n,"")] -> Just $ toInt ity (n :: Integer)+ _ -> Just $ VConstant (I 0)+strToInt _ _ = Nothing -bits32ToInt [VConstant (B32 x)] = Just $ VConstant (I (fromIntegral x))-bits32ToInt _ = Nothing+intToFloat val | Just i <- getInt val = Just $ VConstant (Fl (fromIntegral i))+intToFloat _ = Nothing -c_intToStr [VConstant (I x)] = Just $ VConstant (Str (show x))-c_intToStr _ = Nothing-c_strToInt [VConstant (Str x)] = case reads x of- [(n,"")] -> Just $ VConstant (I n)- _ -> Just $ VConstant (I 0)-c_strToInt _ = Nothing+floatToInt ity [VConstant (Fl x)] = Just $ toInt ity (truncate x :: Integer)+floatToInt _ _ = Nothing c_intToChar [VConstant (I x)] = Just $ VConstant (Ch (toEnum x)) c_intToChar _ = Nothing c_charToInt [VConstant (Ch x)] = Just $ VConstant (I (fromEnum x)) c_charToInt _ = Nothing -c_intToBigInt [VConstant (I x)] = Just $ VConstant (BI (fromIntegral x))-c_intToBigInt _ = Nothing-c_bigIntToInt [VConstant (BI x)] = Just $ VConstant (I (fromInteger x))-c_bigIntToInt _ = Nothing--c_bigIntToStr [VConstant (BI x)] = Just $ VConstant (Str (show x))-c_bigIntToStr _ = Nothing-c_strToBigInt [VConstant (Str x)] = case reads x of- [(n,"")] -> Just $ VConstant (BI n)- _ -> Just $ VConstant (BI 0)-c_strToBigInt _ = Nothing- c_floatToStr [VConstant (Fl x)] = Just $ VConstant (Str (show x)) c_floatToStr _ = Nothing c_strToFloat [VConstant (Str x)] = case reads x of@@ -601,12 +388,6 @@ _ -> Just $ VConstant (Fl 0) c_strToFloat _ = Nothing -c_floatToInt [VConstant (Fl x)] = Just $ VConstant (I (truncate x))-c_floatToInt _ = Nothing--c_intToFloat [VConstant (I x)] = Just $ VConstant (Fl (fromIntegral x))-c_intToFloat _ = Nothing- p_fPrim f [VConstant (Fl x)] = Just $ VConstant (Fl (f x)) p_fPrim f _ = Nothing @@ -622,6 +403,8 @@ p_floatFloor = p_fPrim (fromInteger . floor) p_floatCeil = p_fPrim (fromInteger . ceiling) +p_strLen [VConstant (Str xs)] = Just $ VConstant (I (length xs))+p_strLen _ = Nothing p_strHead [VConstant (Str (x:xs))] = Just $ VConstant (Ch x) p_strHead _ = Nothing p_strTail [VConstant (Str (x:xs))] = Just $ VConstant (Str xs)
src/Idris/Prover.hs view
@@ -20,12 +20,13 @@ import Control.Monad.State import Util.Pretty+import Debug.Trace prover :: Bool -> Name -> Idris () prover lit x = do ctxt <- getContext i <- getIState- case lookupTy Nothing x ctxt of+ case lookupTy x ctxt of [t] -> if elem x (idris_metavars i) then prove ctxt lit x t else fail $ show x ++ " is not a metavariable"@@ -59,6 +60,11 @@ let tree = simpleCase False True CompileTime (FC "proof" 0) [([], P Ref n ty, tm)] logLvl 3 (show tree) (ptm, pty) <- recheckC (FC "proof" 0) [] tm+ logLvl 5 ("Proof type: " ++ show pty ++ "\n" ++ + "Expected type:" ++ show ty)+ case converts ctxt [] ty pty of+ OK _ -> return ()+ Error e -> ierror (CantUnify False ty pty e [] 0) ptm' <- applyOpts ptm updateContext (addCasedef n True False True False [Right (P Ref n ty, ptm)]@@ -72,9 +78,9 @@ fail (pshow i a) dumpState :: IState -> ProofState -> IO ()-dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _) =+dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _) = putStrLn . render $ pretty nm <> colon <+> text "No more goals."-dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ problems i _ _ ctxy _ _) = do+dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _) = do let OK ty = goalAtFocus ps let OK env = envAtFocus ps putStrLn . render $@@ -154,6 +160,7 @@ return (False, e, True, prf) Right tac -> do (_, e) <- elabStep e saveState (_, st) <- elabStep e (runTac True i tac)+-- trace (show (problems (proof st))) $ return (True, st, False, prf ++ [step])) (\err -> do iputStrLn (show err) return (False, e, False, prf))
+ src/Idris/Providers.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE PatternGuards #-}+module Idris.Providers (providerTy, getProvided) where++import Core.TT+import Core.Evaluate+import Core.Execute+import Idris.AbsSyntax+import Idris.AbsSyntaxTree+import Idris.Error++import Debug.Trace++-- | Wrap a type provider in the type of type providers+providerTy :: FC -> PTerm -> PTerm+providerTy fc tm = PApp fc (PRef fc $ UN "Provider") [PExp 0 False tm ""]++-- | Handle an error, if the type provider returned an error. Otherwise return the provided term.+getProvided :: TT Name -> Idris (TT Name)+getProvided tm | (P _ (UN "io_return") _, [tp, result]) <- unApply tm+ , (P _ (NS (UN "Error") ["Providers"]) _, [_, err]) <- unApply result =+ case err of+ Constant (Str msg) -> ierror . ProviderError $ msg+ _ -> fail "Internal error in type provider, non-normalised error"+ | (P _ (UN "io_return") _, [tp, result]) <- unApply tm+ , (P _ (NS (UN "Provide") ["Providers"]) _, [_, res]) <- unApply result =+ return res+ | otherwise = fail $ "Internal type provider error: result was not " +++ "IO (Provider a), or perhaps missing normalisation."
src/Idris/REPL.hs view
@@ -16,12 +16,16 @@ import Idris.Coverage import Idris.UnusedArgs import Idris.Docs+import Idris.Help import Idris.Completion+import Idris.IdeSlave import Paths_idris import Util.System+import Util.DynamicLinker import Core.Evaluate+import Core.Execute (execute) import Core.ProofShell import Core.TT import Core.Constraints@@ -50,16 +54,21 @@ import Data.Char import Data.Version +import Debug.Trace+ -- | Run the REPL repl :: IState -- ^ The initial state -> [FilePath] -- ^ The loaded modules -> InputT Idris () repl orig mods = H.catch- (do let prompt = mkPrompt mods- x <- getInputLine (prompt ++ "> ")+ (do let quiet = opt_quiet (idris_options orig)+ let prompt = if quiet+ then ""+ else mkPrompt mods ++ "> "+ x <- getInputLine prompt case x of- Nothing -> do lift $ iputStrLn "Bye bye"+ Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye") return () Just input -> H.catch (do ms <- lift $ processInput input orig mods@@ -72,6 +81,104 @@ ctrlC e = do lift $ iputStrLn (show e) repl orig mods +-- | Run the IdeSlave+ideslaveStart :: IState -> [FilePath] -> Idris ()+ideslaveStart orig mods+ = do i <- getIState+ case idris_outputmode i of+ IdeSlave n ->+ when (mods /= []) (do liftIO $ putStrLn $ convSExp "set-prompt" (mkPrompt mods) n)+ ideslave orig mods+++ideslave :: IState -> [FilePath] -> Idris ()+ideslave orig mods+ = do idrisCatch+ (do l <- liftIO $ getLine+ let (sexp, id) = parseMessage l+ i <- getIState+ putIState $ i { idris_outputmode = (IdeSlave id) }+ case sexpToCommand sexp of+ Just (Interpret cmd) ->+ do let fn = case mods of+ (f:_) -> f+ _ -> ""+ case parseCmd i cmd of+ Left err -> iFail $ show err+ Right cmd -> idrisCatch+ (do ideslaveProcess fn cmd)+ (\e -> do iFail $ show e)+ Just (REPLCompletions str) ->+ do (unused, compls) <- replCompletion (reverse str, "")+ let good = SexpList [SymbolAtom "ok", toSExp (map replacement compls, reverse unused)]+ liftIO $ putStrLn $ convSExp "return" good id+ Just (LoadFile filename) ->+ do clearErr+ putIState (orig { idris_options = idris_options i,+ idris_outputmode = (IdeSlave id) })+ loadModule filename+ iucheck+ liftIO $ putStrLn $ convSExp "set-prompt" (mkPrompt [filename]) id+ -- report success! or failure!+ ideslave orig [filename]+ Nothing -> do iFail "did not understand")+ (\e -> do iFail $ show e)+ ideslave orig mods++ideslaveProcess :: FilePath -> Command -> Idris ()+ideslaveProcess fn Help = process fn Help+ideslaveProcess fn (ChangeDirectory f) = do process fn (ChangeDirectory f)+ iResult "changed directory to"+ideslaveProcess fn (Eval t) = process fn (Eval t)+ideslaveProcess fn (ExecVal t) = process fn (ExecVal t)+ideslaveProcess fn (Check (PRef x n)) = process fn (Check (PRef x n))+ideslaveProcess fn (Check t) = process fn (Check t)+ideslaveProcess fn (DocStr n) = process fn (DocStr n)+ideslaveProcess fn Universes = process fn Universes+ideslaveProcess fn (Defn n) = do process fn (Defn n)+ iResult ""+ideslaveProcess fn (TotCheck n) = process fn (TotCheck n)+ideslaveProcess fn (DebugInfo n) = do process fn (DebugInfo n)+ iResult ""+ideslaveProcess fn (Info n) = process fn (Info n)+ideslaveProcess fn (Search t) = process fn (Search t)+ideslaveProcess fn (Spec t) = process fn (Spec t)+-- RmProof and AddProof not supported!+ideslaveProcess fn (ShowProof n') = process fn (ShowProof n')+ideslaveProcess fn (Prove n') = process fn (Prove n')+ideslaveProcess fn (HNF t) = process fn (HNF t)+--ideslaveProcess fn TTShell = process fn TTShell -- need some prove mode!++--that most likely does not work, since we need to wrap+--input/output of the executed binary...+ideslaveProcess fn Execute = do process fn Execute+ iResult ""+ideslaveProcess fn (NewCompile f) = do process fn (NewCompile f)+ iResult ""+ideslaveProcess fn (Compile target f) = do process fn (Compile target f)+ iResult ""+ideslaveProcess fn (LogLvl i) = do process fn (LogLvl i)+ iResult ""+ideslaveProcess fn (Pattelab t) = process fn (Pattelab t)+ideslaveProcess fn (Missing n) = process fn (Missing n)+ideslaveProcess fn (DynamicLink l) = do process fn (DynamicLink l)+ iResult ""+ideslaveProcess fn ListDynamic = do process fn ListDynamic+ iResult ""+ideslaveProcess fn Metavars = process fn Metavars+ideslaveProcess fn (SetOpt ErrContext) = do process fn (SetOpt ErrContext)+ iResult ""+ideslaveProcess fn (UnsetOpt ErrContext) = do process fn (UnsetOpt ErrContext)+ iResult ""+ideslaveProcess fn (SetOpt ShowImpl) = do process fn (SetOpt ShowImpl)+ iResult ""+ideslaveProcess fn (UnsetOpt ShowImpl) = do process fn (UnsetOpt ShowImpl)+ iResult ""+ideslaveProcess fn (SetOpt x) = process fn (SetOpt x)+ideslaveProcess fn (UnsetOpt x) = process fn (UnsetOpt x)+ideslaveProcess fn _ = iFail "command not recognized or not supported"++ -- | The prompt consists of the currently loaded modules, or "Idris" if there are none mkPrompt [] = "Idris" mkPrompt [x] = "*" ++ dropExtension x@@ -85,6 +192,8 @@ processInput :: String -> IState -> [FilePath] -> Idris (Maybe [FilePath]) processInput cmd orig inputs = do i <- getIState+ let opts = idris_options i+ let quiet = opt_quiet opts let fn = case inputs of (f:_) -> f _ -> ""@@ -109,7 +218,7 @@ return (Just inputs) Right Proofs -> do proofs orig return (Just inputs)- Right Quit -> do iputStrLn "Bye bye"+ Right Quit -> do when (not quiet) (iputStrLn "Bye bye") return Nothing Right cmd -> do idrisCatch (process fn cmd) (\e -> iputStrLn (show e))@@ -119,7 +228,7 @@ resolveProof n' = do i <- getIState ctxt <- getContext- n <- case lookupNames Nothing n' ctxt of+ n <- case lookupNames n' ctxt of [x] -> return x [] -> return n' ns -> fail $ pshow i (CantResolveAlts (map show ns))@@ -163,112 +272,115 @@ insertScript :: String -> [String] -> [String] insertScript prf [] = "\n---------- Proofs ----------" : "" : [prf]-insertScript prf (p@"---------- Proofs ----------" : "" : xs) +insertScript prf (p@"---------- Proofs ----------" : "" : xs) = p : "" : prf : xs insertScript prf (x : xs) = x : insertScript prf xs process :: FilePath -> Command -> Idris ()-process fn Help = iputStrLn displayHelp-process fn (Eval t) +process fn Help = iResult displayHelp+process fn (ChangeDirectory f)+ = do liftIO $ setCurrentDirectory f+ return ()+process fn (Eval t) = do (tm, ty) <- elabVal toplevel False t ctxt <- getContext- ist <- getIState + ist <- getIState let tm' = normaliseAll ctxt [] tm let ty' = normaliseAll ctxt [] ty logLvl 3 $ "Raw: " ++ show (tm', ty') imp <- impShow- iputStrLn (showImp imp (delab ist tm') ++ " : " ++ - showImp imp (delab ist ty'))-process fn (ExecVal t) - = do (tm, ty) <- elabVal toplevel False t --- (PApp fc (PRef fc (NS (UN "print") ["Prelude"]))--- [pexp t])- (tmpn, tmph) <- liftIO tempfile- liftIO $ hClose tmph- t <- target- compile t tmpn tm- liftIO $ system tmpn- return ()- where fc = FC "(input)" 0 -process fn (Check (PRef _ n))+ iResult (showImp imp (delab ist tm') ++ " : " +++ showImp imp (delab ist ty'))+process fn (ExecVal t) = do ctxt <- getContext ist <- getIState+ (tm, ty) <- elabVal toplevel False t+-- let tm' = normaliseAll ctxt [] tm+ let ty' = normaliseAll ctxt [] ty+ res <- execute tm imp <- impShow- case lookupTy Nothing n ctxt of- ts@(_:_) -> mapM_ (\t -> iputStrLn $ show n ++ " : " ++- showImp imp (delab ist t)) ts- [] -> iputStrLn $ "No such variable " ++ show n+ iResult (showImp imp (delab ist res) ++ " : " +++ showImp imp (delab ist ty'))+process fn (Check (PRef _ n))+ = do ctxt <- getContext+ ist <- getIState+ imp <- impShow+ case lookupNames n ctxt of+ ts@(_:_) -> do mapM_ (\n -> iputStrLn $ show n ++ " : " +++ showImp imp (delabTy ist n)) ts+ iResult ""+ [] -> iFail $ "No such variable " ++ show n process fn (Check t) = do (tm, ty) <- elabVal toplevel False t ctxt <- getContext- ist <- getIState + ist <- getIState imp <- impShow let ty' = normaliseC ctxt [] ty- iputStrLn (showImp imp (delab ist tm) ++ " : " ++ - showImp imp (delab ist ty))+ iResult (showImp imp (delab ist tm) ++ " : " +++ showImp imp (delab ist ty)) process fn (DocStr n) = do i <- getIState- case lookupCtxtName Nothing n (idris_docstrings i) of- [] -> iputStrLn $ "No documentation for " ++ show n- ns -> mapM_ showDoc ns - where showDoc (n, d) + case lookupCtxtName n (idris_docstrings i) of+ [] -> iFail $ "No documentation for " ++ show n+ ns -> do mapM_ showDoc ns+ iResult ""+ where showDoc (n, d) = do doc <- getDocs n iputStrLn $ show doc process fn Universes = do i <- getIState let cs = idris_constraints i -- iputStrLn $ showSep "\n" (map show cs)- liftIO $ print (map fst cs)+ iputStrLn $ show (map fst cs) let n = length cs iputStrLn $ "(" ++ show n ++ " constraints)" case ucheck cs of- Error e -> iputStrLn $ pshow i e- OK _ -> iputStrLn "Universes OK"+ Error e -> iFail $ pshow i e+ OK _ -> iResult "Universes OK" process fn (Defn n) = do i <- getIState iputStrLn "Compiled patterns:\n"- liftIO $ print (lookupDef Nothing n (tt_ctxt i))- case lookupCtxt Nothing n (idris_patdefs i) of+ iputStrLn $ show (lookupDef n (tt_ctxt i))+ case lookupCtxt n (idris_patdefs i) of [] -> return ()- [d] -> do iputStrLn "Original definiton:\n"- mapM_ (printCase i) d+ [(d, _)] -> do iputStrLn "Original definiton:\n"+ mapM_ (printCase i) d case lookupTotal n (tt_ctxt i) of [t] -> iputStrLn (showTotal t i) _ -> return ()- where printCase i (_, lhs, rhs) - = do liftIO $ putStr $ showImp True (delab i lhs)- liftIO $ putStr " = "- liftIO $ putStrLn $ showImp True (delab i rhs)+ where printCase i (_, lhs, rhs)+ = do iputStrLn (showImp True (delab i lhs) ++ " = " +++ showImp True (delab i rhs)) process fn (TotCheck n) = do i <- getIState case lookupTotal n (tt_ctxt i) of- [t] -> iputStrLn (showTotal t i)- _ -> return ()-process fn (DebugInfo n) + [t] -> iResult (showTotal t i)+ _ -> do iFail ""+ return ()+process fn (DebugInfo n) = do i <- getIState- let oi = lookupCtxtName Nothing n (idris_optimisation i)+ let oi = lookupCtxtName n (idris_optimisation i) when (not (null oi)) $ iputStrLn (show oi)- let si = lookupCtxt Nothing n (idris_statics i)+ let si = lookupCtxt n (idris_statics i) when (not (null si)) $ iputStrLn (show si)- let di = lookupCtxt Nothing n (idris_datatypes i)+ let di = lookupCtxt n (idris_datatypes i) when (not (null di)) $ iputStrLn (show di)- let d = lookupDef Nothing n (tt_ctxt i)- when (not (null d)) $ liftIO $- do print (head d)- let cg = lookupCtxtName Nothing n (idris_callgraph i)+ let d = lookupDef n (tt_ctxt i)+ when (not (null d)) $ iputStrLn (show (head d))+ let cg = lookupCtxtName n (idris_callgraph i) findUnusedArgs (map fst cg) i <- getIState- let cg' = lookupCtxtName Nothing n (idris_callgraph i)+ let cg' = lookupCtxtName n (idris_callgraph i) sc <- checkSizeChange n iputStrLn $ "Size change: " ++ show sc when (not (null cg')) $ do iputStrLn "Call graph:\n" iputStrLn (show cg') process fn (Info n) = do i <- getIState- case lookupCtxt Nothing n (idris_classes i) of+ case lookupCtxt n (idris_classes i) of [c] -> classInfo c- _ -> iputStrLn "Not a class"-process fn (Search t) = iputStrLn "Not implemented"+ _ -> iFail "Not a class"+process fn (Search t) = iFail "Not implemented" process fn (Spec t) = do (tm, ty) <- elabVal toplevel False t ctxt <- getContext ist <- getIState let tm' = simplify ctxt True [] {- (idris_statics ist) -} tm- iputStrLn (show (delab ist tm'))+ iResult (show (delab ist tm')) process fn (RmProof n') = do i <- getIState@@ -286,8 +398,17 @@ let ms = idris_metavars i putIState $ i { idris_metavars = n : ms } -process fn (AddProof prf)- = do let fb = fn ++ "~"+process fn' (AddProof prf)+ = do fn <- do+ ex <- liftIO $ doesFileExist fn'+ let fnExt = fn' <.> "idr"+ exExt <- liftIO $ doesFileExist fnExt+ if ex+ then return fn'+ else if exExt+ then return fnExt+ else fail $ "Neither \""++fn'++"\" nor \""++fnExt++"\" exist"+ let fb = fn ++ "~" liftIO $ copyFile fn fb -- make a backup in case something goes wrong! prog <- liftIO $ readFile fb i <- getIState@@ -311,13 +432,13 @@ n <- resolveProof n' let proofs = proof_list i case lookup n proofs of- Nothing -> iputStrLn "No proof to show"- Just p -> iputStrLn $ showProof False n p+ Nothing -> iFail "No proof to show"+ Just p -> iResult $ showProof False n p process fn (Prove n') = do ctxt <- getContext ist <- getIState- n <- case lookupNames Nothing n' ctxt of+ n <- case lookupNames n' ctxt of [x] -> return x [] -> return n' ns -> fail $ pshow ist (CantResolveAlts (map show ns))@@ -332,13 +453,13 @@ ctxt <- getContext ist <- getIState let tm' = hnf ctxt [] tm- iputStrLn (show (delab ist tm'))+ iResult (show (delab ist tm')) process fn TTShell = do ist <- getIState let shst = initState (tt_ctxt ist) runShell shst return ()-process fn Execute = do (m, _) <- elabVal toplevel False - (PApp fc +process fn Execute = do (m, _) <- elabVal toplevel False+ (PApp fc (PRef fc (UN "run__IO")) [pexp $ PRef fc (NS (UN "main") ["Main"])]) -- (PRef (FC "main" 0) (NS (UN "main") ["main"]))@@ -348,38 +469,51 @@ compile t tmpn m liftIO $ system tmpn return ()- where fc = FC "main" 0 -process fn (NewCompile f) + where fc = FC "main" 0+process fn (NewCompile f) = do (m, _) <- elabVal toplevel False (PApp fc (PRef fc (UN "run__IO")) [pexp $ PRef fc (NS (UN "main") ["Main"])]) compileEpic f m- where fc = FC "main" 0 -process fn (Compile target f) + where fc = FC "main" 0+process fn (Compile target f) = do (m, _) <- elabVal toplevel False (PApp fc (PRef fc (UN "run__IO")) [pexp $ PRef fc (NS (UN "main") ["Main"])]) compile target f m- where fc = FC "main" 0 -process fn (LogLvl i) = setLogLevel i + where fc = FC "main" 0+process fn (LogLvl i) = setLogLevel i -- Elaborate as if LHS of a pattern (debug command)-process fn (Pattelab t) +process fn (Pattelab t) = do (tm, ty) <- elabVal toplevel True t- iputStrLn $ show tm ++ "\n\n : " ++ show ty+ iResult $ show tm ++ "\n\n : " ++ show ty -process fn (Missing n) = do i <- getIState- case lookupDef Nothing n (tt_ctxt i) of- [CaseOp _ _ _ _ _ args t _ _]- -> do tms <- genMissing n args t- iputStrLn (showSep "\n" (map (showImp True) tms))- [] -> iputStrLn $ show n ++ " undefined"- _ -> iputStrLn $ "Ambiguous name"-process fn Metavars +process fn (Missing n)+ = do i <- getIState+ case lookupCtxt n (idris_patdefs i) of+ [] -> return ()+ [(_, tms)] ->+ iResult (showSep "\n" (map (showImp True) tms))+ _ -> iFail $ "Ambiguous name"+process fn (DynamicLink l) = do i <- getIState+ let lib = trim l+ handle <- lift $ tryLoadLib lib+ case handle of+ Nothing -> iFail $ "Could not load dynamic lib \"" ++ l ++ "\""+ Just x -> do let libs = idris_dynamic_libs i+ putIState $ i { idris_dynamic_libs = x:libs }+ where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace+process fn ListDynamic = do i <- getIState+ iputStrLn "Dynamic libraries:"+ showLibs $ idris_dynamic_libs i+ where showLibs [] = return ()+ showLibs ((Lib name _):ls) = do iputStrLn $ "\t" ++ name; showLibs ls+process fn Metavars = do ist <- getIState let mvs = idris_metavars ist \\ primDefs case mvs of- [] -> iputStrLn "No global metavariables to solve"- _ -> iputStrLn $ "Global metavariables:\n\t" ++ show mvs+ [] -> iFail "No global metavariables to solve"+ _ -> iResult $ "Global metavariables:\n\t" ++ show mvs process fn NOP = return () process fn (SetOpt ErrContext) = setErrContext True@@ -387,8 +521,8 @@ process fn (SetOpt ShowImpl) = setImpShow True process fn (UnsetOpt ShowImpl) = setImpShow False -process fn (SetOpt _) = iputStrLn "Not a valid option"-process fn (UnsetOpt _) = iputStrLn "Not a valid option"+process fn (SetOpt _) = iFail "Not a valid option"+process fn (UnsetOpt _) = iFail "Not a valid option" classInfo :: ClassInfo -> Idris ()@@ -397,6 +531,7 @@ iputStrLn "" iputStrLn "Instances:\n" mapM_ dumpInstance (class_instances ci)+ iResult "" dumpMethod :: (Name, (FnOpts, PTerm)) -> Idris () dumpMethod (n, (_, t)) = iputStrLn $ show n ++ " : " ++ show t@@ -405,7 +540,7 @@ dumpInstance n = do i <- getIState ctxt <- getContext imp <- impShow- case lookupTy Nothing n ctxt of+ case lookupTy n ctxt of ts -> mapM_ (\t -> iputStrLn $ showImp imp (delab i t)) ts showTotal t@(Partial (Other ns)) i@@ -418,8 +553,9 @@ displayHelp = let vstr = showVersion version in "\nIdris version " ++ vstr ++ "\n" ++ "--------------" ++ map (\x -> '-') vstr ++ "\n\n" +++ concatMap cmdInfo helphead ++ concatMap cmdInfo help- where cmdInfo (cmds, args, text) = " " ++ col 16 12 (showSep " " cmds) args text + where cmdInfo (cmds, args, text) = " " ++ col 16 12 (showSep " " cmds) (show args) text col c1 c2 l m r = l ++ take (c1 - length l) (repeat ' ') ++ m ++ take (c2 - length m) (repeat ' ') ++ r ++ "\n"@@ -434,66 +570,47 @@ parseArgs :: [String] -> [Opt] parseArgs [] = []-parseArgs ("--log":lvl:ns) = OLogging (read lvl) : (parseArgs ns)-parseArgs ("--noprelude":ns) = NoPrelude : (parseArgs ns)-parseArgs ("--check":ns) = NoREPL : (parseArgs ns)-parseArgs ("-o":n:ns) = NoREPL : Output n : (parseArgs ns)-parseArgs ("-no":n:ns) = NoREPL : NewOutput n : (parseArgs ns)-parseArgs ("--typecase":ns) = TypeCase : (parseArgs ns)-parseArgs ("--typeintype":ns) = TypeInType : (parseArgs ns)-parseArgs ("--total":ns) = DefaultTotal : (parseArgs ns)-parseArgs ("--partial":ns) = DefaultPartial : (parseArgs ns)-parseArgs ("--warnpartial":ns) = WarnPartial : (parseArgs ns)-parseArgs ("--nocoverage":ns) = NoCoverage : (parseArgs ns)-parseArgs ("--errorcontext":ns) = ErrContext : (parseArgs ns)-parseArgs ("--help":ns) = Usage : (parseArgs ns)-parseArgs ("--link":ns) = ShowLibs : (parseArgs ns)-parseArgs ("--libdir":ns) = ShowLibdir : (parseArgs ns)-parseArgs ("--include":ns) = ShowIncs : (parseArgs ns)-parseArgs ("--version":ns) = Ver : (parseArgs ns)-parseArgs ("--verbose":ns) = Verbose : (parseArgs ns)-parseArgs ("--ibcsubdir":n:ns) = IBCSubDir n : (parseArgs ns)-parseArgs ("-i":n:ns) = ImportDir n : (parseArgs ns)-parseArgs ("--warn":ns) = WarnOnly : (parseArgs ns)-parseArgs ("--package":n:ns) = Pkg n : (parseArgs ns)-parseArgs ("-p":n:ns) = Pkg n : (parseArgs ns)-parseArgs ("--build":n:ns) = PkgBuild n : (parseArgs ns)-parseArgs ("--install":n:ns) = PkgInstall n : (parseArgs ns)-parseArgs ("--clean":n:ns) = PkgClean n : (parseArgs ns)-parseArgs ("--bytecode":n:ns) = NoREPL : BCAsm n : (parseArgs ns)-parseArgs ("--fovm":n:ns) = NoREPL : FOVM n : (parseArgs ns)-parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns)-parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns)-parseArgs ("--dumpdefuns":n:ns) = DumpDefun n : (parseArgs ns)-parseArgs ("--dumpcases":n:ns) = DumpCases n : (parseArgs ns)-parseArgs ("--target":n:ns) = UseTarget (parseTarget n) : (parseArgs ns)-parseArgs (n:ns) = Filename n : (parseArgs ns)+parseArgs ("--quiet":ns) = Quiet : (parseArgs ns)+parseArgs ("--ideslave":ns) = Ideslave : (parseArgs ns)+parseArgs ("--log":lvl:ns) = OLogging (read lvl) : (parseArgs ns)+parseArgs ("--noprelude":ns) = NoPrelude : (parseArgs ns)+parseArgs ("--check":ns) = NoREPL : (parseArgs ns)+parseArgs ("-o":n:ns) = NoREPL : Output n : (parseArgs ns)+parseArgs ("-no":n:ns) = NoREPL : NewOutput n : (parseArgs ns)+parseArgs ("--typecase":ns) = TypeCase : (parseArgs ns)+parseArgs ("--typeintype":ns) = TypeInType : (parseArgs ns)+parseArgs ("--total":ns) = DefaultTotal : (parseArgs ns)+parseArgs ("--partial":ns) = DefaultPartial : (parseArgs ns)+parseArgs ("--warnpartial":ns) = WarnPartial : (parseArgs ns)+parseArgs ("--nocoverage":ns) = NoCoverage : (parseArgs ns)+parseArgs ("--errorcontext":ns) = ErrContext : (parseArgs ns)+parseArgs ("--help":ns) = Usage : (parseArgs ns)+parseArgs ("--link":ns) = ShowLibs : (parseArgs ns)+parseArgs ("--libdir":ns) = ShowLibdir : (parseArgs ns)+parseArgs ("--include":ns) = ShowIncs : (parseArgs ns)+parseArgs ("--version":ns) = Ver : (parseArgs ns)+parseArgs ("--verbose":ns) = Verbose : (parseArgs ns)+parseArgs ("--ibcsubdir":n:ns) = IBCSubDir n : (parseArgs ns)+parseArgs ("-i":n:ns) = ImportDir n : (parseArgs ns)+parseArgs ("--warn":ns) = WarnOnly : (parseArgs ns)+parseArgs ("--package":n:ns) = Pkg n : (parseArgs ns)+parseArgs ("-p":n:ns) = Pkg n : (parseArgs ns)+parseArgs ("--build":n:ns) = PkgBuild n : (parseArgs ns)+parseArgs ("--install":n:ns) = PkgInstall n : (parseArgs ns)+parseArgs ("--clean":n:ns) = PkgClean n : (parseArgs ns)+parseArgs ("--bytecode":n:ns) = NoREPL : BCAsm n : (parseArgs ns)+parseArgs ("--fovm":n:ns) = NoREPL : FOVM n : (parseArgs ns)+parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns)+parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns)+parseArgs ("--dumpdefuns":n:ns) = DumpDefun n : (parseArgs ns)+parseArgs ("--dumpcases":n:ns) = DumpCases n : (parseArgs ns)+parseArgs ("--target":n:ns) = UseTarget (parseTarget n) : (parseArgs ns)+parseArgs ("-XTypeProviders":ns) = Extension TypeProviders : (parseArgs ns)+parseArgs (n:ns) = Filename n : (parseArgs ns) -help =- [ (["Command"], "Arguments", "Purpose"),- ([""], "", ""),- (["<expr>"], "", "Evaluate an expression"),- ([":t"], "<expr>", "Check the type of an expression"),- ([":miss", ":missing"], "<name>", "Show missing clauses"),- ([":i", ":info"], "<name>", "Display information about a type class"),- ([":total"], "<name>", "Check the totality of a name"),- ([":r",":reload"], "", "Reload current file"),- ([":l",":load"], "<filename>", "Load a new file"),- ([":m",":module"], "<module>", "Import an extra module"),- ([":e",":edit"], "", "Edit current file using $EDITOR or $VISUAL"),- ([":m",":metavars"], "", "Show remaining proof obligations (metavariables)"),- ([":p",":prove"], "<name>", "Prove a metavariable"),- ([":a",":addproof"], "<name>", "Add proof to source file"),- ([":rmproof"], "<name>", "Remove proof from proof stack"),- ([":showproof"], "<name>", "Show proof"),- ([":proofs"], "", "Show available proofs"),- ([":c",":compile"], "<filename>", "Compile to an executable <filename>"),- ([":js", ":javascript"], "<filename>", "Compile to JavaScript <filename>"),- ([":exec",":execute"], "", "Compile to an executable and run"),- ([":?",":h",":help"], "", "Display this help text"),- ([":set"], "<option>", "Set an option (errorcontext, showimplicits)"),- ([":unset"], "<option>", "Unset an option"),- ([":q",":quit"], "", "Exit the Idris system")+helphead =+ [ (["Command"], SpecialHeaderArg, "Purpose"),+ ([""], NoArg, "") ] @@ -507,6 +624,8 @@ idrisMain :: [Opt] -> Idris () idrisMain opts = do let inputs = opt getFile opts+ let quiet = Quiet `elem` opts+ let idesl = Ideslave `elem` opts let runrepl = not (NoREPL `elem` opts) let output = opt getOutput opts let newoutput = opt getNewOutput opts@@ -523,7 +642,10 @@ xs -> last xs when (DefaultTotal `elem` opts) $ do i <- getIState putIState (i { default_total = True })+ mapM_ addLangExt (opt getLanguageExt opts) setREPL runrepl+ setQuiet quiet+ setIdeSlave idesl setVerbose runrepl setCmdLine opts setOutputTy outty@@ -542,12 +664,13 @@ [] -> setIBCSubDir "" (d:_) -> setIBCSubDir d setImportDirs importdirs+ addPkgDir "base" mapM_ addPkgDir pkgdirs elabPrims when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude" return ()- when runrepl $ iputStrLn banner+ when (runrepl && not quiet && not idesl) $ iputStrLn banner ist <- getIState mods <- mapM loadModule inputs ok <- noErrors@@ -557,7 +680,8 @@ when ok $ case newoutput of [] -> return () (o:_) -> process "" (NewCompile o) - when runrepl $ runInputT replSettings $ repl ist inputs+ when (runrepl && not idesl) $ runInputT replSettings $ repl ist inputs+ when (idesl) $ ideslaveStart ist inputs ok <- noErrors when (not ok) $ liftIO (exitWith (ExitFailure 1)) where@@ -621,8 +745,12 @@ getOutputTy (OutputTy t) = Just t getOutputTy _ = Nothing +getLanguageExt :: Opt -> Maybe LanguageExt+getLanguageExt (Extension e) = Just e+getLanguageExt _ = Nothing+ opt :: (Opt -> Maybe a) -> [Opt] -> [a]-opt = mapMaybe +opt = mapMaybe ver = showVersion version
src/Idris/REPLParser.hs view
@@ -45,16 +45,19 @@ <|> try (do cmd ["showproof"]; n <- pName; eof; return (ShowProof n)) <|> try (do cmd ["log"]; i <- natural; eof; return (LogLvl (fromIntegral i))) <|> try (do cmd ["l", "load"]; f <- getInput; return (Load f))+ <|> try (do cmd ["cd"]; f <- getInput; return (ChangeDirectory f)) <|> try (do cmd ["spec"]; t <- pFullExpr defaultSyntax; return (Spec t)) <|> try (do cmd ["hnf"]; t <- pFullExpr defaultSyntax; return (HNF t)) <|> try (do cmd ["doc"]; n <- pfName; eof; return (DocStr n))- <|> try (do cmd ["d", "def"]; n <- pfName; eof; return (Defn n))+ <|> try (do cmd ["d", "def"]; many1 (char ' ') ; n <- pfName; eof; return (Defn n)) <|> try (do cmd ["total"]; do n <- pfName; eof; return (TotCheck n)) <|> try (do cmd ["t", "type"]; do t <- pFullExpr defaultSyntax; return (Check t)) <|> try (do cmd ["u", "universes"]; eof; return Universes) <|> try (do cmd ["di", "dbginfo"]; n <- pfName; eof; return (DebugInfo n)) <|> try (do cmd ["i", "info"]; n <- pfName; eof; return (Info n)) <|> try (do cmd ["miss", "missing"]; n <- pfName; eof; return (Missing n))+ <|> try (do cmd ["dynamic"]; eof; return ListDynamic)+ <|> try (do cmd ["dynamic"]; l <- getInput; return (DynamicLink l)) <|> try (do cmd ["set"]; o <-pOption; return (SetOpt o)) <|> try (do cmd ["unset"]; o <-pOption; return (UnsetOpt o)) <|> try (do cmd ["s", "search"]; t <- pFullExpr defaultSyntax; return (Search t))@@ -63,7 +66,7 @@ <|> do t <- pFullExpr defaultSyntax; return (Eval t) <|> do eof; return NOP - where toPath n = foldl1 (</>) $ splitOn "." n+ where toPath n = foldl1' (</>) $ splitOn "." n pOption :: IParser Opt pOption = do discard (symbol "errorcontext"); return ErrContext
src/Idris/UnusedArgs.hs view
@@ -15,7 +15,7 @@ traceUnused :: Name -> Idris () traceUnused n = do i <- getIState- case lookupCtxt Nothing n (idris_callgraph i) of + case lookupCtxt n (idris_callgraph i) of [CGInfo args calls scg usedns _] -> do let argpos = zip args [0..] let fargs = concatMap (getFargpos calls) argpos@@ -39,7 +39,7 @@ | otherwise = do logLvl 5 $ (show ((g, j) : path)) i <- getIState- case lookupCtxt Nothing g (idris_callgraph i) of+ case lookupCtxt g (idris_callgraph i) of [CGInfo args calls scg usedns unused] -> if (j >= length args) then -- overapplied, assume used
src/Main.hs view
@@ -29,6 +29,7 @@ import Idris.Error import Util.System ( getLibFlags, getIdrisLibDir, getIncFlags )+import Util.DynamicLinker import Pkg.Package @@ -78,6 +79,7 @@ "--------------" ++ map (\x -> '-') ver ++ "\n" ++ "Usage: idris [input file] [options]\n" ++ "Options:\n" +++ "\t--quiet Quiet mode (for editors)\n" ++ "\t--check Type check only\n" ++ "\t-o [file] Specify output filename\n" ++ "\t-i [dir] Add directory to the list of import paths\n" ++@@ -89,7 +91,10 @@ "\t--log [level] Type debugging log level\n" ++ "\t-S Do no further compilation of code generator output\n" ++ "\t-c Compile to object files rather than an executable\n" +++ "\t--ideslave Ideslave mode (for editors; in/ouput wrapped in s-expressions)\n" ++ "\t--libdir Show library install directory and exit\n" ++ "\t--link Show C library directories and exit (for C linking)\n" ++ "\t--include Show C include directories and exit (for C linking)\n" ++ "\t--target [target] Type the target: C, Java, bytecode, javascript, node\n"++
src/Pkg/Package.hs view
@@ -71,7 +71,7 @@ buildMods opts ns = do let f = map (toPath . show) ns idris (map Filename f ++ opts) return ()- where toPath n = foldl1 (</>) $ splitOn "." n+ where toPath n = foldl1' (</>) $ splitOn "." n testLib :: Bool -> String -> String -> IO Bool testLib warn p f @@ -93,7 +93,7 @@ rmIBC m = rmFile $ toIBCFile m toIBCFile (UN n) = n ++ ".ibc"-toIBCFile (NS n ns) = foldl1 (</>) (reverse (toIBCFile n : ns))+toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : ns)) installIBC :: String -> Name -> IO () installIBC p m = do let f = toIBCFile m@@ -105,7 +105,7 @@ copyFile f (destdir </> takeFileName f) return () where getDest (UN n) = ""- getDest (NS n ns) = foldl1 (</>) (reverse (getDest n : ns))+ getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : ns)) installObj :: String -> String -> IO () installObj p o = do d <- getDataDir
+ src/Util/DynamicLinker.hs view
@@ -0,0 +1,63 @@+-- | Platform-specific dynamic linking support. Add new platforms to this file+-- through conditional compilation.+{-# LANGUAGE ExistentialQuantification, CPP #-}+module Util.DynamicLinker where++import Foreign.LibFFI+import Foreign.Ptr (nullPtr, FunPtr, nullFunPtr,castPtrToFunPtr)+import System.Directory+#ifndef WINDOWS+import System.Posix.DynamicLinker+#else+import System.Win32.DLL+import System.Win32.Types+type DL = HMODULE+#endif++hostDynamicLibExt :: String+#ifdef LINUX+hostDynamicLibExt = "so"+#elif MACOSX+hostDynamicLibExt = "dylib"+#elif WINDOWS+hostDynamicLibExt = "dll"+#endif++data ForeignFun = forall a. Fun { fun_name :: String+ , fun_handle :: FunPtr a+ }++data DynamicLib = Lib { lib_name :: String+ , lib_handle :: DL+ }++#ifndef WINDOWS+tryLoadLib :: String -> IO (Maybe DynamicLib)+tryLoadLib lib = do exactName <- doesFileExist lib+ let filename = if exactName then lib else lib ++ "." ++ hostDynamicLibExt+ handle <- dlopen filename [RTLD_NOW, RTLD_GLOBAL]+ if undl handle == nullPtr+ then return Nothing+ else return . Just $ Lib lib handle+++tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)+tryLoadFn fn (Lib _ h) = do cFn <- dlsym h fn+ if cFn == nullFunPtr+ then return Nothing+ else return . Just $ Fun fn cFn+#else+tryLoadLib :: String -> IO (Maybe DynamicLib)+tryLoadLib lib = do exactName <- doesFileExist lib+ let filename = if exactName then lib else lib ++ "." ++ hostDynamicLibExt+ handle <- loadLibrary filename+ if handle == nullPtr+ then return Nothing+ else return . Just $ Lib lib handle++tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)+tryLoadFn fn (Lib _ h) = do cFn <- getProcAddress h fn+ if cFn == nullPtr+ then return Nothing+ else return . Just $ Fun fn (castPtrToFunPtr cFn)+#endif
src/Util/System.hs view
@@ -1,13 +1,20 @@ {-# LANGUAGE CPP #-}-module Util.System(tempfile,environment,getCC,- getLibFlags,getIdrisLibDir,getIncFlags,rmFile) where+module Util.System(tempfile,withTempdir,environment,getCC,+ getLibFlags,getIdrisLibDir,getIncFlags,rmFile,+ getMvn,getExecutablePom,catchIO) where -- System helper functions.--import System.Directory (getTemporaryDirectory, removeFile)+import Control.Monad (when)+import Distribution.Text (display)+import System.Directory (getTemporaryDirectory+ , removeFile+ , removeDirectoryRecursive+ , createDirectoryIfMissing+ ) import System.FilePath ((</>), addTrailingPathSeparator, normalise) import System.Environment import System.IO+import System.IO.Error #if MIN_VERSION_base(4,0,0) import Control.Exception as CE #endif@@ -17,20 +24,44 @@ #if MIN_VERSION_base(4,0,0) catchIO :: IO a -> (IOError -> IO a) -> IO a catchIO = CE.catch++throwIO :: IOError -> IO a+throwIO = CE.throw #else catchIO = catch+throwIO = throw #endif ++ getCC :: IO String getCC = do env <- environment "IDRIS_CC" case env of Nothing -> return "gcc" Just cc -> return cc +getMvn :: IO String+getMvn = do env <- environment "IDRIS_MVN"+ case env of+ Nothing -> return "mvn"+ Just mvn -> return mvn+ tempfile :: IO (FilePath, Handle) tempfile = do dir <- getTemporaryDirectory openTempFile (normalise dir) "idris" +withTempdir :: String -> (FilePath -> IO a) -> IO a+withTempdir subdir callback + = do dir <- getTemporaryDirectory+ let tmpDir = (normalise dir) </> subdir+ removeLater <- catchIO (createDirectoryIfMissing True tmpDir >> return True)+ (\ ioError -> if isAlreadyExistsError ioError then return False + else throw ioError+ )+ result <- callback tmpDir+ when removeLater $ removeDirectoryRecursive tmpDir+ return result+ environment :: String -> IO (Maybe String) environment x = catchIO (do e <- getEnv x return (Just e))@@ -51,3 +82,6 @@ getIncFlags = do dir <- getDataDir return $ "-I" ++ dir </> "rts"++getExecutablePom = do dir <- getDataDir+ return $ dir </> "executable_pom.xml"
+ tutorial/examples/wheres.idr view
@@ -0,0 +1,14 @@+module wheres++even : Nat -> Bool +even O = True +even (S k) = odd k where + odd O = False + odd (S k) = even k ++test : List Nat+test = [c (S 1), c O, d (S O)]+ where c x = 42 + x+ d y = c (y + 1 + z y)+ where z w = y + w+