diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -24,6 +24,9 @@ test_llvm: $(MAKE) -C test IDRIS=../dist/build/idris test_llvm +test_js: + $(MAKE) -C test IDRIS=../dist/build/idris test_js + test_all: $(MAKE) test $(MAKE) test_llvm diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,12 +1,15 @@ {-# LANGUAGE CPP #-} import Control.Monad import Data.IORef +import Control.Exception (SomeException, catch) import Distribution.Simple +import Distribution.Simple.BuildPaths (autogenModulesDir) 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.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFile) import Distribution.PackageDescription import Distribution.Text @@ -35,7 +38,7 @@ -- Make Commands -- use GNU make on FreeBSD -#ifdef freebsd_HOST_OS +#if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) mymake = "gmake" #else mymake = "make" @@ -60,6 +63,13 @@ Just False -> False Nothing -> True +isRelease :: S.ConfigFlags -> Bool +isRelease flags = + case lookup (FlagName "release") (S.configConfigurationsFlags flags) of + Just True -> True + Just False -> False + Nothing -> False + -- ----------------------------------------------------------------------------- -- Clean @@ -80,8 +90,30 @@ -- ----------------------------------------------------------------------------- -- Configure +gitHash :: IO String +gitHash = do h <- Control.Exception.catch (readProcess "git" ["rev-parse", "--short", "HEAD"] "") + (\e -> let e' = (e :: SomeException) in return "PRE") + return $ takeWhile (/= '\n') h + +-- Put the Git hash into a module for use in the program +-- For release builds, just put the empty string in the module +generateVersionModule verbosity dir release = do + hash <- gitHash + let versionModulePath = dir "Version_idris" Px.<.> "hs" + putStrLn $ "Generating " ++ versionModulePath ++ + if release then " for release" else (" for prerelease " ++ hash) + createDirectoryIfMissingVerbose verbosity True dir + rewriteFile versionModulePath (versionModuleContents hash) + + where versionModuleContents h = "module Version_idris where\n\n" ++ + "gitHash :: String\n" ++ + if release + then "gitHash = \"\"\n" + else "gitHash = \"-git:" ++ h ++ "\"\n" + idrisConfigure _ flags _ local = do configureRTS + generateVersionModule verbosity (autogenModulesDir local) (isRelease (configFlags local)) where verbosity = S.fromFlag $ S.configVerbosity flags version = pkgVersion . package $ localPkgDescr local @@ -92,9 +124,28 @@ -- the file after configure. configureRTS = make verbosity ["-C", "rts", "clean"] +idrisPreSDist args flags = do + let dir = S.fromFlag (S.sDistDirectory flags) + let verb = S.fromFlag (S.sDistVerbosity flags) + generateVersionModule verb ("src") True + preSDist simpleUserHooks args flags + +idrisPostSDist args flags desc lbi = do + Control.Exception.catch (do let file = "src" "Version_idris" Px.<.> "hs" + putStrLn $ "Removing generated module " ++ file + removeFile file) + (\e -> let e' = (e :: SomeException) in return ()) + postSDist simpleUserHooks args flags desc lbi + -- ----------------------------------------------------------------------------- -- Build +getVersion :: Args -> S.BuildFlags -> IO HookedBuildInfo +getVersion args flags = do + hash <- gitHash + let buildinfo = (emptyBuildInfo { cppOptions = ["-DVERSION="++hash] }) :: BuildInfo + return (Just buildinfo, []) + idrisBuild _ flags _ local = do buildStdLib buildRTS @@ -116,6 +167,7 @@ gmpflag False = [] gmpflag True = ["GMP=-DIDRIS_GMP"] + -- ----------------------------------------------------------------------------- -- Copy/Install @@ -158,4 +210,6 @@ , postInst = \_ flags pkg local -> idrisInstall (S.fromFlag $ S.installVerbosity flags) NoCopyDest pkg local + , preSDist = idrisPreSDist --do { putStrLn (show args) ; putStrLn (show flags) ; return emptyHookedBuildInfo } + , postSDist = idrisPostSDist } diff --git a/idris.cabal b/idris.cabal --- a/idris.cabal +++ b/idris.cabal @@ -1,5 +1,5 @@ Name: idris -Version: 0.9.10.1 +Version: 0.9.11 License: BSD3 License-file: LICENSE Author: Edwin Brady @@ -14,7 +14,7 @@ Dependent types allow types to be predicated on values, meaning that some aspects of a program's behaviour can be specified precisely in the type. The language is closely - related to Epigram and Agda. There is a tutorial at + related to Epigram and Agda. There is a tutorial at . Features include: . @@ -42,7 +42,7 @@ . * Hugs style interactive environment -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 Build-type: Custom @@ -77,6 +77,7 @@ libs/base/base.ipkg libs/base/*.idr libs/base/Control/*.idr + libs/base/Control/Isomorphism/*.idr libs/base/Control/Monad/*.idr libs/base/Data/*.idr libs/base/Data/Vect/*.idr @@ -87,6 +88,7 @@ libs/base/Makefile libs/base/Network/*.idr libs/base/System/Concurrency/*.idr + libs/base/Syntax/*.idr libs/effects/Makefile @@ -94,6 +96,11 @@ libs/effects/Effect/*.idr libs/effects/*.idr + libs/neweffects/Makefile + libs/neweffects/neweffects.ipkg + libs/neweffects/Effect/*.idr + libs/neweffects/*.idr + libs/javascript/*.idr libs/javascript/JavaScript/*.idr libs/javascript/Makefile @@ -176,115 +183,174 @@ test/reg024/run test/reg024/*.idr test/reg024/expected - test/test001/run - test/test001/*.idr - test/test001/expected - test/test002/run - test/test002/*.idr - test/test002/expected - test/test003/run - test/test003/*.lidr - test/test003/expected - test/test004/run - test/test004/*.idr - test/test004/expected - test/test005/run - test/test005/*.idr - test/test005/expected - test/test006/run - test/test006/*.idr - test/test006/expected - test/test007/run - test/test007/*.idr - test/test007/expected - test/test008/run - test/test008/*.idr - test/test008/expected - test/test009/run - test/test009/*.idr - test/test009/expected - test/test010/run - test/test010/*.idr - test/test010/expected - test/test011/run - test/test011/*.idr - test/test011/expected - test/test012/run - test/test012/*.idr - test/test012/expected - test/test013/run - test/test013/*.idr - test/test013/expected - test/test014/run - test/test014/*.idr - test/test014/test - test/test014/expected - test/test015/run - test/test015/*.idr - test/test015/expected - test/test016/run - test/test016/*.idr - test/test016/expected - test/test017/run - test/test017/*.idr - test/test017/expected - test/test018/run - test/test018/*.idr - test/test018/expected - test/test019/run - test/test019/*.lidr - test/test019/expected - test/test020/run - test/test020/*.idr - test/test020/expected - test/test021/run - test/test021/*.idr - test/test021/testFile - test/test021/expected - test/test022/run - test/test022/*.idr - test/test022/expected - test/test023/run - test/test023/*.idr - test/test023/expected - test/test024/run - test/test024/*.idr - test/test024/input - test/test024/expected - test/test025/run - test/test025/*.idr - test/test025/expected - test/test026/run - test/test026/*.idr - test/test026/input - test/test026/theType - test/test026/theOtherType - test/test026/expected - test/test027/run - test/test027/*.idr - test/test027/expected - test/test028/run - test/test028/*.idr - test/test028/expected - test/test029/run - test/test029/*.idr - test/test029/expected - test/test030/run - test/test030/*.idr - test/test030/expected - test/test031/run - test/test031/*.idr - test/test031/expected - test/test032/run - test/test032/*.idr - test/test032/input - test/test032/expected - test/test033/run - test/test033/*.idr - test/test033/expected - test/test034/run - test/test034/expected + test/reg025/run + test/reg025/*.idr + test/reg025/expected + test/reg026/run + test/reg026/*.idr + test/reg026/expected + test/reg027/run + test/reg027/*.idr + test/reg027/expected + test/reg028/run + test/reg028/*.idr + test/reg028/expected + test/reg029/run + test/reg029/*.idr + test/reg029/expected + test/reg030/run + test/reg030/*.idr + test/reg030/expected + test/reg031/run + test/reg031/*.idr + test/reg031/expected + test/reg032/run + test/reg032/*.idr + test/reg032/expected + test/basic001/run + test/basic001/*.idr + test/basic001/expected + test/basic002/run + test/basic002/*.idr + test/basic002/expected + test/basic003/run + test/basic003/*.idr + test/basic003/expected + test/basic004/run + test/basic004/*.idr + test/basic004/expected + test/basic005/run + test/basic005/*.lidr + test/basic005/expected + test/basic006/run + test/basic006/*.idr + test/basic006/expected + test/basic007/run + test/basic007/*.idr + test/basic007/expected + test/basic008/run + test/basic008/*.idr + test/basic008/expected + test/basic009/run + test/basic009/*.idr + test/basic009/expected + test/basic009/B/*.idr + + test/buffer001-disabled/*.idr + test/buffer001-disabled/run + test/buffer001-disabled/expected + + test/dsl001/run + test/dsl001/*.idr + test/dsl001/expected + test/dsl002/run + test/dsl002/test + test/dsl002/*.idr + test/dsl002/expected + + test/effects001/run + test/effects001/*.idr + test/effects001/expected + test/effects001/testFile + test/effects002/run + test/effects002/*.idr + test/effects002/expected + + test/error001/run + test/error001/*.idr + test/error001/expected + test/error002/run + test/error002/*.idr + test/error002/expected + test/error003/run + test/error003/*.idr + test/error003/expected + test/error004/run + test/error004/*.idr + test/error004/expected + + test/ffi001/run + test/ffi001/*.idr + test/ffi001/expected + test/ffi002/run + test/ffi002/*.idr + test/ffi002/expected + test/ffi003/run + test/ffi003/*.idr + test/ffi003/expected + test/ffi003/input + test/ffi004/run + test/ffi004/*.idr + test/ffi004/theType + test/ffi004/theOtherType + test/ffi004/expected + + test/interactive001/run + test/interactive001/input + test/interactive001/*.idr + test/interactive001/expected + + test/io001/run + test/io001/*.idr + test/io001/expected + test/io002/run + test/io002/*.idr + test/io002/expected + test/io003/run + test/io003/*.idr + test/io003/expected + + test/literate001/run + test/literate001/*.lidr + test/literate001/expected + + test/primitives001/run + test/primitives001/*.idr + test/primitives001/expected + test/primitives002/run + test/primitives002/expected + test/primitives003/run + test/primitives003/*.idr + test/primitives003/expected + + test/proof001/run + test/proof001/*.idr + test/proof001/expected + test/proof002/run + test/proof002/*.idr + test/proof002/expected + test/proof003/run + test/proof003/*.idr + test/proof003/expected + test/proof004/run + test/proof004/*.idr + test/proof004/expected + + test/records001/run + test/records001/*.idr + test/records001/expected + + test/sugar001/run + test/sugar001/*.idr + test/sugar001/expected + test/sugar002/run + test/sugar002/*.idr + test/sugar002/expected + test/sugar003/run + test/sugar003/*.idr + test/sugar003/expected + + test/totality001/run + test/totality001/*.idr + test/totality001/expected + test/totality002/run + test/totality002/*.idr + test/totality002/expected + test/totality003/run + test/totality003/*.idr + test/totality003/expected + source-repository head type: git location: git://github.com/idris-lang/Idris-dev.git @@ -304,19 +370,32 @@ Default: False manual: True -Executable idris - Main-is: Main.hs +Flag curses + Description: Use Curses to get the screen width + Default: False + manual: True + +-- This flag determines whether to show Git hashes in version strings +-- Defaults to True because Hackage is a source release +Flag release + Description: This is an official release + Default: True + manual: True + +Library hs-source-dirs: src - Other-modules: - Core.CaseTree - , Core.Constraints - , Core.Elaborate - , Core.Evaluate - , Core.Execute - , Core.ProofState - , Core.TT - , Core.Typecheck - , Core.Unify + Exposed-modules: + Idris.Core.CaseTree + , Idris.Core.Constraints + , Idris.Core.DeepSeq + , Idris.Core.Elaborate + , Idris.Core.Evaluate + , Idris.Core.Execute + , Idris.Core.ProofState + , Idris.Core.TC + , Idris.Core.TT + , Idris.Core.Typecheck + , Idris.Core.Unify , Idris.AbsSyntax , Idris.AbsSyntaxTree @@ -333,6 +412,7 @@ , Idris.ElabDecls , Idris.ElabTerm , Idris.Error + , Idris.ErrReverse , Idris.Help , Idris.IBC , Idris.IdeSlave @@ -370,40 +450,46 @@ , IRTS.Java.Pom , IRTS.Lang , IRTS.Simplified + , IRTS.System - , Util.Pretty - , Util.System + , Pkg.Package , Util.DynamicLinker + , Util.ScreenSize + + Other-modules: + Util.Pretty + , Util.System , Util.Net + , Util.Zlib - , Pkg.Package , Pkg.PParser -- Auto Generated - Paths_idris + , Paths_idris + , Version_idris Build-depends: base >=4 && <5 , Cabal + , annotated-wl-pprint >= 0.5.3 , ansi-terminal , ansi-wl-pprint , binary , bytestring - , containers + , containers >= 0.5 , directory , directory >= 1.2 , filepath , haskeline >= 0.7 , language-java >= 0.2.6 , mtl - --, parsec >= 3 - , parsers == 0.9 + , parsers >= 0.9 , pretty , process , split , text , time >= 1.4 , transformers - , trifecta == 1.1 + , trifecta >= 1.1 , unordered-containers , utf8-string , vector @@ -411,9 +497,10 @@ , network , xml , deepseq - + , zlib Extensions: MultiParamTypeClasses , FunctionalDependencies + , FlexibleContexts , FlexibleInstances , TemplateHaskell @@ -445,4 +532,21 @@ if flag(GMP) build-depends: libffi cpp-options: -DIDRIS_GMP + if flag(curses) + build-depends: hscurses + cpp-options: -DCURSES + +Executable idris + Main-is: Main.hs + hs-source-dirs: main + + Build-depends: idris + , base + , filepath + , haskeline >= 0.7 + , transformers + + ghc-prof-options: -auto-all -caf-all + ghc-options: -threaded -rtsopts -funbox-strict-fields + diff --git a/jsrts/Runtime-common.js b/jsrts/Runtime-common.js --- a/jsrts/Runtime-common.js +++ b/jsrts/Runtime-common.js @@ -14,12 +14,6 @@ var __IDRRT__Ptr = new __IDRRT__Type('Pointer'); var __IDRRT__Forgot = new __IDRRT__Type('Forgot'); - -/** @constructor */ -var __IDRRT__Cont = function(k) { - this.k = k; -}; - var __IDRRT__ffiWrap = function(fid) { return function(){ var res = fid; @@ -34,12 +28,6 @@ } return res; } -}; - -/** @constructor */ -var __IDRRT__Con = function(tag,vars) { - this.tag = tag; - this.vars = vars; }; var __IDRRT__tailcall = function(k) { diff --git a/libs/Makefile b/libs/Makefile --- a/libs/Makefile +++ b/libs/Makefile @@ -1,20 +1,23 @@ -build: .PHONY +build: $(MAKE) -C prelude build $(MAKE) -C base build $(MAKE) -C effects build + $(MAKE) -C neweffects build $(MAKE) -C javascript build -install: .PHONY +install: $(MAKE) -C prelude install $(MAKE) -C base install $(MAKE) -C effects install + $(MAKE) -C neweffects install $(MAKE) -C javascript install -clean: .PHONY +clean: $(MAKE) -C prelude clean $(MAKE) -C base clean $(MAKE) -C effects clean + $(MAKE) -C neweffects clean $(MAKE) -C javascript clean -.PHONY: +.PHONY: build install clean diff --git a/libs/base/Control/Isomorphism.idr b/libs/base/Control/Isomorphism.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/Isomorphism.idr @@ -0,0 +1,290 @@ +module Control.Isomorphism + +import Syntax.PreorderReasoning +import Uninhabited + +%default total + +-- An isomorphism between two types +data Iso : Type -> Type -> Type where + MkIso : (to : a -> b) -> + (from : b -> a) -> + (toFrom : (y : b) -> to (from y) = y) -> + (fromTo : (x : a) -> from (to x) = x) -> + Iso a b + +-- Isomorphism properties + +isoRefl : Iso a a +isoRefl = MkIso id id (\x => refl) (\x => refl) + +isoTrans : Iso a b -> Iso b c -> Iso a c +isoTrans (MkIso to from toFrom fromTo) (MkIso to' from' toFrom' fromTo') = + MkIso (\x => to' (to x)) + (\y => from (from' y)) + (\y => (to' (to (from (from' y)))) ={ cong (toFrom (from' y)) }= + (to' (from' y)) ={ toFrom' y }= + y QED) + (\x => (from (from' (to' (to x)))) ={ cong (fromTo' (to x)) }= + (from (to x)) ={ fromTo x }= + x QED) + +isoSym : Iso a b -> Iso b a +isoSym (MkIso to from toFrom fromTo) = MkIso from to fromTo toFrom + +-- Isomorphisms over sums + +eitherComm : Iso (Either a b) (Either b a) +eitherComm = MkIso swap swap swapSwap swapSwap + where swap : Either a b -> Either b a + swap (Left x) = Right x + swap (Right x) = Left x + swapSwap : (e : Either a b) -> swap (swap e) = e + swapSwap (Left x) = refl + swapSwap (Right x) = refl + +eitherAssoc : Iso (Either (Either a b) c) (Either a (Either b c)) +eitherAssoc = MkIso eitherAssoc1 eitherAssoc2 ok1 ok2 + where eitherAssoc1 : Either (Either a b) c -> Either a (Either b c) + eitherAssoc1 (Left (Left x)) = Left x + eitherAssoc1 (Left (Right x)) = Right (Left x) + eitherAssoc1 (Right x) = Right (Right x) + + eitherAssoc2 : Either a (Either b c) -> Either (Either a b) c + eitherAssoc2 (Left x) = Left (Left x) + eitherAssoc2 (Right (Left x)) = Left (Right x) + eitherAssoc2 (Right (Right x)) = Right x + + ok1 : (x : Either a (Either b c)) -> eitherAssoc1 (eitherAssoc2 x) = x + ok1 (Left x) = refl + ok1 (Right (Left x)) = refl + ok1 (Right (Right x)) = refl + + ok2 : (x : Either (Either a b) c) -> eitherAssoc2 (eitherAssoc1 x) = x + ok2 (Left (Left x)) = refl + ok2 (Left (Right x)) = refl + ok2 (Right x) = refl + +eitherBotLeft : Iso (Either _|_ a) a +eitherBotLeft = MkIso to from ok1 ok2 + where to : Either _|_ a -> a + to (Left x) = FalseElim x + to (Right x) = x + from : a -> Either _|_ a + from = Right + ok1 : (x : a) -> to (from x) = x + ok1 x = refl + ok2 : (x : Either _|_ a) -> from (to x) = x + ok2 (Left x) = FalseElim x + ok2 (Right x) = refl + +eitherBotRight : Iso (Either a _|_) a +eitherBotRight = isoTrans eitherComm eitherBotLeft + + +eitherCong : Iso a a' -> Iso b b' -> Iso (Either a b) (Either a' b') +eitherCong {a = a} {a' = a'} {b = b} {b' = b'} + (MkIso to from toFrom fromTo) + (MkIso to' from' toFrom' fromTo') = + MkIso (eitherMap to to') (eitherMap from from') ok1 ok2 + where eitherMap : (c -> c') -> (d -> d') -> Either c d -> Either c' d' + eitherMap f g (Left x) = Left (f x) + eitherMap f g (Right x) = Right (g x) + ok1 : (x : Either a' b') -> eitherMap to to' (eitherMap from from' x) = x + ok1 (Left x) = cong (toFrom x) + ok1 (Right x) = cong (toFrom' x) + ok2 : (x : Either a b) -> eitherMap from from' (eitherMap to to' x) = x + ok2 (Left x) = cong (fromTo x) + ok2 (Right x) = cong (fromTo' x) + +eitherCongLeft : Iso a a' -> Iso (Either a b) (Either a' b) +eitherCongLeft i = eitherCong i isoRefl + +eitherCongRight : Iso b b' -> Iso (Either a b) (Either a b') +eitherCongRight i = eitherCong isoRefl i + +-- Isomorphisms over products +pairComm : Iso (a, b) (b, a) +pairComm = MkIso swap swap swapSwap swapSwap + where swap : (a, b) -> (b, a) + swap (x, y) = (y, x) + swapSwap : (x : (a, b)) -> swap (swap x) = x + swapSwap (x, y) = refl + +pairAssoc : Iso (a, (b, c)) ((a, b), c) +pairAssoc = MkIso to from ok1 ok2 + where + to : (a, (b, c)) -> ((a, b), c) + to (x, (y, z)) = ((x, y), z) + from : ((a, b), c) -> (a, (b, c)) + from ((x, y), z) = (x, (y, z)) + ok1 : (x : ((a, b), c)) -> to (from x) = x + ok1 ((x, y), z) = refl + ok2 : (x : (a, (b, c))) -> from (to x) = x + ok2 (x, (y, z)) = refl + +pairUnitRight : Iso (a, ()) a +pairUnitRight = MkIso fst (\x => (x, ())) (\x => refl) ok + where ok : (x : (a, ())) -> (fst x, ()) = x + ok (x, ()) = refl + +pairUnitLeft : Iso ((), a) a +pairUnitLeft = isoTrans pairComm pairUnitRight + +pairBotLeft : Iso (_|_, a) _|_ +pairBotLeft = MkIso fst FalseElim (\x => FalseElim x) (\y => FalseElim (fst y)) + +pairBotRight : Iso (a, _|_) _|_ +pairBotRight = isoTrans pairComm pairBotLeft + +pairCong : Iso a a' -> Iso b b' -> Iso (a, b) (a', b') +pairCong {a = a} {a' = a'} {b = b} {b' = b'} + (MkIso to from toFrom fromTo) + (MkIso to' from' toFrom' fromTo') = + MkIso to'' from'' iso1 iso2 + where to'' : (a, b) -> (a', b') + to'' (x, y) = (to x, to' y) + from'' : (a', b') -> (a, b) + from'' (x, y) = (from x, from' y) + iso1 : (x : (a', b')) -> to'' (from'' x) = x + iso1 (x, y) = rewrite toFrom x in + rewrite toFrom' y in + refl + iso2 : (x : (a, b)) -> from'' (to'' x) = x + iso2 (x, y) = rewrite fromTo x in + rewrite fromTo' y in + refl + +pairCongLeft : Iso a a' -> Iso (a, b) (a', b) +pairCongLeft i = pairCong i isoRefl + +pairCongRight : Iso b b' -> Iso (a, b) (a, b') +pairCongRight = pairCong isoRefl + +-- Distributivity of products over sums +distribLeft : Iso (Either a b, c) (Either (a, c) (b, c)) +distribLeft = MkIso to from toFrom fromTo + where to : (Either a b, c) -> Either (a, c) (b, c) + to (Left x, y) = Left (x, y) + to (Right x, y) = Right (x, y) + from : Either (a, c) (b, c) -> (Either a b, c) + from (Left (x, y)) = (Left x, y) + from (Right (x, y)) = (Right x, y) + toFrom : (x : Either (a, c) (b, c)) -> to (from x) = x + toFrom (Left (x, y)) = refl + toFrom (Right (x, y)) = refl + fromTo : (x : (Either a b, c)) -> from (to x) = x + fromTo (Left x, y) = refl + fromTo (Right x, y) = refl + +distribRight : Iso (a, Either b c) (Either (a, b) (a, c)) +distribRight {a} {b} {c} = (pairComm `isoTrans` distribLeft) `isoTrans` eitherCong pairComm pairComm + + +-- Enable preorder reasoning syntax over isomorphisms +qed : (a : Type) -> Iso a a +qed a = isoRefl + +step : (a : Type) -> Iso a b -> Iso b c -> Iso a c +step a iso1 iso2 = isoTrans iso1 iso2 + + + +-- Isomorphisms over Maybe +maybeCong : Iso a b -> Iso (Maybe a) (Maybe b) +maybeCong {a} {b} (MkIso to from toFrom fromTo) = MkIso (map to) (map from) ok1 ok2 + where ok1 : (y : Maybe b) -> map to (map from y) = y + ok1 Nothing = refl + ok1 (Just x) = (Just (to (from x))) ={ cong (toFrom x) }= (Just x) QED + ok2 : (x : Maybe a) -> map from (map to x) = x + ok2 Nothing = refl + ok2 (Just x) = (Just (from (to x))) ={ cong (fromTo x) }= (Just x) QED + +maybeEither : Iso (Maybe a) (Either a ()) +maybeEither = MkIso to from iso1 iso2 + where to : Maybe a -> Either a () + to Nothing = Right () + to (Just x) = Left x + from : Either a () -> Maybe a + from (Left x) = Just x + from (Right ()) = Nothing + iso1 : (x : Either a ()) -> to (from x) = x + iso1 (Left x) = refl + iso1 (Right ()) = refl + iso2 : (y : Maybe a) -> from (to y) = y + iso2 Nothing = refl + iso2 (Just x) = refl + +maybeVoidUnit : Iso (Maybe _|_) () +maybeVoidUnit = (Maybe _|_) ={ maybeEither }= + (Either _|_ ()) ={ eitherBotLeft }= + () QED + +eitherMaybeLeftMaybe : Iso (Either (Maybe a) b) (Maybe (Either a b)) +eitherMaybeLeftMaybe {a} {b} = + (Either (Maybe a) b) ={ eitherCongLeft maybeEither }= + (Either (Either a ()) b) ={ eitherAssoc }= + (Either a (Either () b)) ={ eitherCongRight eitherComm }= + (Either a (Either b ())) ={ isoSym eitherAssoc }= + (Either (Either a b) ()) ={ isoSym maybeEither }= + (Maybe (Either a b)) QED + + +eitherMaybeRightMaybe : Iso (Either a (Maybe b)) (Maybe (Either a b)) +eitherMaybeRightMaybe {a} {b} = + (Either a (Maybe b)) ={ eitherComm }= + (Either (Maybe b) a) ={ eitherMaybeLeftMaybe }= + (Maybe (Either b a)) ={ maybeCong eitherComm }= + (Maybe (Either a b)) QED + + +-- Isomorphisms over Fin + +maybeIsoS : Iso (Maybe (Fin n)) (Fin (S n)) +maybeIsoS = MkIso forth back fb bf + where forth : Maybe (Fin n) -> Fin (S n) + forth Nothing = fZ + forth (Just x) = fS x + back : Fin (S n) -> Maybe (Fin n) + back fZ = Nothing + back (fS x) = Just x + bf : (x : Maybe (Fin n)) -> back (forth x) = x + bf Nothing = refl + bf (Just x) = refl + fb : (y : Fin (S n)) -> forth (back y) = y + fb fZ = refl + fb (fS x) = refl + +finZeroBot : Iso (Fin 0) _|_ +finZeroBot = MkIso (\x => FalseElim (uninhabited x)) + (\x => FalseElim x) + (\x => FalseElim x) + (\x => FalseElim (uninhabited x)) + +eitherFinPlus : Iso (Either (Fin m) (Fin n)) (Fin (m + n)) +eitherFinPlus {m = Z} {n=n} = + (Either (Fin 0) (Fin n)) ={ eitherCongLeft finZeroBot }= + (Either _|_ (Fin n)) ={ eitherBotLeft }= + (Fin n) QED +eitherFinPlus {m = S k} {n=n} = + (Either (Fin (S k)) (Fin n)) ={ eitherCongLeft (isoSym maybeIsoS) }= + (Either (Maybe (Fin k)) (Fin n)) ={ eitherMaybeLeftMaybe }= + (Maybe (Either (Fin k) (Fin n))) ={ maybeCong eitherFinPlus }= + (Maybe (Fin (k + n))) ={ maybeIsoS }= + (Fin (S (k + n))) QED + + +finPairTimes : Iso (Fin m, Fin n) (Fin (m * n)) +finPairTimes {m = Z} {n=n} = + (Fin Z, Fin n) ={ pairCongLeft finZeroBot }= + (_|_, Fin n) ={ pairBotLeft }= + _|_ ={ isoSym finZeroBot }= + (Fin Z) QED +finPairTimes {m = S k} {n=n} = + (Fin (S k), Fin n) ={ pairCongLeft (isoSym maybeIsoS) }= + (Maybe (Fin k), Fin n) ={ pairCongLeft maybeEither }= + (Either (Fin k) (), Fin n) ={ distribLeft }= + (Either (Fin k, Fin n) ((), Fin n)) ={ eitherCong finPairTimes pairUnitLeft }= + (Either (Fin (k * n)) (Fin n)) ={ eitherComm }= + (Either (Fin n) (Fin (k * n))) ={ eitherFinPlus }= + (Fin (n + (k * n))) QED diff --git a/libs/base/Control/Isomorphism/Primitives.idr b/libs/base/Control/Isomorphism/Primitives.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/Isomorphism/Primitives.idr @@ -0,0 +1,35 @@ +module Control.Isomorphism.Primitives + +import Control.Isomorphism +import Data.ZZ + +%default total +%access public + +-- This module contains isomorphisms between convenient inductive types and +-- Idris primitives. Because primitives lack a convenient structure, these +-- arguments typically end with "really_believe_me". This is why they are in a +-- separate module. + +integerIsoZZ : Iso Integer ZZ +integerIsoZZ = MkIso toZZ fromZZ fromToZZ toFromZZ + where toZZ : Integer -> ZZ + toZZ n = cast n + + fromZZ : ZZ -> Integer + fromZZ n = cast n + + toFromZZ : (n : Integer) -> fromZZ (toZZ n) = n + toFromZZ n = really_believe_me {a = n=n} {b = fromZZ (toZZ n) = n} refl + + fromToZZ : (n : ZZ) -> toZZ (fromZZ n) = n + fromToZZ n = really_believe_me {a = n=n} {b = toZZ (fromZZ n) = n} refl + + +packUnpackIso : Iso (List Char) String +packUnpackIso = MkIso pack + unpack + (\str => really_believe_me {a = str=str} {b = pack (unpack str) = str} refl) + (\cs => really_believe_me {a = cs=cs} {b = unpack (pack cs) = cs} refl) + + diff --git a/libs/base/Data/Buffer.idr b/libs/base/Data/Buffer.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Buffer.idr @@ -0,0 +1,252 @@ +module Data.Buffer + +%default total + +-- !!! TODO: Open issues: +-- 1. It may be theoretically nice to represent Buffer size as +-- Fin (2 ^ WORD_BITS) instead of Nat +-- 2. Primitives take Bits64 when really they should take the +-- equivalent of C's size_t (ideally unboxed) +-- 3. If we had access to host system information, we could reduce +-- the needed primitives by implementing the LE/BE variants on +-- top of the native variant plus a possible swab function +-- 4. Would be nice to be able to peek/append Int, Char, and Float, +-- all have fixed (though possibly implementation-dependent) widths. +-- Currently not in place due to lack of host system introspection. +-- 5. Would be nice to be able to peek/append the vector types, but +-- for now I'm only touching the C backend which AFAICT doesn't +-- support them. +-- 6. Conversion from Fin to Bits64 (which, re 2, should eventually +-- be a fixed-width implementation-dependent type) is likely +-- inefficient relative to conversion from Nat to Bits64 +-- 7. We may want to have a separate type that is a product of Buffer +-- and offset rather than storing the offset in Buffer itself, which +-- would require exposing the offset argument of prim__appendBuffer + +-- A contiguous chunk of n bytes +abstract +record Buffer : Nat -> Type where + MkBuffer : ( offset : Nat ) -> ( realBuffer : prim__UnsafeBuffer ) -> Buffer n + +bitsFromNat : Nat -> Bits64 +bitsFromNat Z = 0 +bitsFromNat (S k) = 1 + bitsFromNat k + +bitsFromFin : Fin n -> Bits64 +bitsFromFin fZ = 0 +bitsFromFin (fS k) = 1 + bitsFromFin k + +-- Allocate an empty Buffer. The size hint can be used to avoid +-- unnecessary reallocations and copies under the hood if the +-- approximate ultimate size of the Buffer is known. Users can assume +-- the new Buffer is word-aligned. +public +allocate : ( hint : Nat ) -> Buffer Z +allocate = MkBuffer Z . prim__allocate . bitsFromNat + +-- Append count repetitions of a Buffer to another Buffer +%assert_total +public +appendBuffer : Buffer n -> + ( count : Nat ) -> + Buffer m -> + Buffer ( n + count * m ) +appendBuffer { n } { m } ( MkBuffer o1 r1 ) c ( MkBuffer o2 r2 ) = + MkBuffer o1 $ prim__appendBuffer r1 size1 count size2 off r2 + where + size1 : Bits64 + size1 = bitsFromNat ( n + o1 ) + size2 : Bits64 + size2 = bitsFromNat m + count : Bits64 + count = bitsFromNat c + off : Bits64 + off = bitsFromNat o2 + +-- Copy a buffer, potentially allowing the (potentially large) space it +-- pointed to to be freed +public +copy : Buffer n -> Buffer n +copy { n } = replace ( plusZeroRightNeutral n ) . appendBuffer ( allocate n ) 1 + +-- Create a view over a buffer +public +peekBuffer : { n : Nat } -> { offset : Nat } -> Buffer ( n + offset ) -> ( offset : Nat ) -> Buffer n +peekBuffer ( MkBuffer o r ) off = MkBuffer ( o + off ) r + +peekBits : ( prim__UnsafeBuffer -> Bits64 -> a ) -> + Buffer ( m + n ) -> + ( offset : Fin ( S n ) ) -> + a +peekBits prim ( MkBuffer o r ) = prim r . bitsFromNat . plus o . finToNat + +appendBits : ( prim__UnsafeBuffer -> + Bits64 -> + Bits64 -> + a -> + prim__UnsafeBuffer ) -> + Buffer n -> + ( count : Nat) -> + a -> + Buffer ( n + count * size ) +appendBits { n } prim ( MkBuffer o r ) count = + MkBuffer o . prim r ( bitsFromNat $ n + o ) ( bitsFromNat count ) + + +-- Read a Bits8 from a Buffer starting at offset +%assert_total +public +peekBits8 : Buffer ( 1 + n ) -> + ( offset : Fin ( S n ) ) -> + Bits8 +peekBits8 = peekBits { m = 1 } prim__peekB8Native + +-- Append count repetitions of a Bits8 to a Buffer +%assert_total +public +appendBits8 : Buffer n -> + ( count : Nat ) -> + Bits8 -> + Buffer ( n + count * 1 ) +appendBits8 = appendBits prim__appendB8Native + +-- Read a Bits16 in native byte order from a Buffer starting at offset +%assert_total +public +peekBits16Native : Buffer ( 2 + n ) -> + ( offset : Fin ( S n ) ) -> + Bits16 +peekBits16Native = peekBits { m = 2 } prim__peekB16Native + +-- Read a little-endian Bits16 from a Buffer starting at offset +%assert_total +public +peekBits16LE : Buffer ( 2 + n ) -> ( offset : Fin ( S n ) ) -> Bits16 +peekBits16LE = peekBits { m = 2 } prim__peekB16LE + +-- Read a big-endian Bits16 from a Buffer starting at offset +%assert_total +public +peekBits16BE : Buffer ( 2 + n ) -> ( offset : Fin ( S n ) ) -> Bits16 +peekBits16BE = peekBits { m = 2 } prim__peekB16BE + +-- Append count repetitions of a Bits16 in native byte order to a Buffer +%assert_total +public +appendBits16Native : Buffer n -> + ( count : Nat ) -> + Bits16 -> + Buffer ( n + count * 2 ) +appendBits16Native = appendBits prim__appendB16Native + +-- Append count repetitions of a little-endian Bits16 to a Buffer +%assert_total +public +appendBits16LE : Buffer n -> + ( count : Nat ) -> + Bits16 -> + Buffer ( n + count * 2 ) +appendBits16LE = appendBits prim__appendB16LE + +-- Append count repetitions of a big-endian Bits16 to a Buffer +%assert_total +public +appendBits16BE : Buffer n -> + ( count : Nat ) -> + Bits16 -> + Buffer ( n + count * 2 ) +appendBits16BE = appendBits prim__appendB16BE + +-- Read a Bits32 in native byte order from a Buffer starting at offset +%assert_total +public +peekBits32Native : Buffer ( 4 + n ) -> + ( offset : Fin ( S n ) ) -> + Bits32 +peekBits32Native = peekBits { m = 4 } prim__peekB32Native + +-- Read a little-endian Bits32 from a Buffer starting at offset +%assert_total +public +peekBits32LE : Buffer ( 4 + n ) -> ( offset : Fin ( S n ) ) -> Bits32 +peekBits32LE = peekBits { m = 4 } prim__peekB32LE + +-- Read a big-endian Bits32 from a Buffer starting at offset +%assert_total +public +peekBits32BE : Buffer ( 4 + n ) -> ( offset : Fin ( S n ) ) -> Bits32 +peekBits32BE = peekBits { m = 4 } prim__peekB32BE + +-- Append count repetitions of a Bits32 in native byte order to a Buffer +%assert_total +public +appendBits32Native : Buffer n -> + ( count : Nat ) -> + Bits32 -> + Buffer ( n + count * 4 ) +appendBits32Native = appendBits prim__appendB32Native + +-- Append count repetitions of a little-endian Bits32 to a Buffer +%assert_total +public +appendBits32LE : Buffer n -> + ( count : Nat ) -> + Bits32 -> + Buffer ( n + count * 4 ) +appendBits32LE = appendBits prim__appendB32LE + +-- Append count repetitions of a big-endian Bits32 to a Buffer +%assert_total +public +appendBits32BE : Buffer n -> + ( count : Nat ) -> + Bits32 -> + Buffer ( n + count * 4 ) +appendBits32BE = appendBits prim__appendB32BE + +-- Read a Bits64 in native byte order from a Buffer starting at offset +%assert_total +public +peekBits64Native : Buffer ( 8 + n ) -> + ( offset : Fin ( S n ) ) -> + Bits64 +peekBits64Native = peekBits { m = 8 } prim__peekB64Native + +-- Read a little-endian Bits64 from a Buffer starting at offset +%assert_total +public +peekBits64LE : Buffer ( 8 + n ) -> ( offset : Fin ( S n ) ) -> Bits64 +peekBits64LE = peekBits { m = 8 } prim__peekB64LE + +-- Read a big-endian Bits64 from a Buffer starting at offset +%assert_total +public +peekBits64BE : Buffer ( 8 + n ) -> ( offset : Fin ( S n ) ) -> Bits64 +peekBits64BE = peekBits { m = 8 } prim__peekB64BE + +-- Append count repetitions of a Bits64 in native byte order to a Buffer +%assert_total +public +appendBits64Native : Buffer n -> + ( count : Nat ) -> + Bits64 -> + Buffer ( n + count * 8 ) +appendBits64Native = appendBits prim__appendB64Native + +-- Append count repetitions of a little-endian Bits64 to a Buffer +%assert_total +public +appendBits64LE : Buffer n -> + ( count : Nat ) -> + Bits64 -> + Buffer ( n + count * 8 ) +appendBits64LE = appendBits prim__appendB64LE + +-- Append count repetitions of a big-endian Bits64 to a Buffer +%assert_total +public +appendBits64BE : Buffer n -> + ( count : Nat ) -> + Bits64 -> + Buffer ( n + count * 8 ) +appendBits64BE = appendBits prim__appendB64BE diff --git a/libs/base/Data/Fun.idr b/libs/base/Data/Fun.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Fun.idr @@ -0,0 +1,8 @@ +module Data.Fun + +-------------------------------------------------------------------------------- +-- Build an n-ary function type from a Vect of Types and a result type +-------------------------------------------------------------------------------- +Fun : Vect n Type -> Type -> Type +Fun [] r = r +Fun (t::ts) r = t -> Fun ts r diff --git a/libs/base/Data/Rel.idr b/libs/base/Data/Rel.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Rel.idr @@ -0,0 +1,13 @@ +module Data.Rel + +import Data.Fun + +-------------------------------------------------------------------------------- +-- Build an n-ary relation type from a Vect of Types +-------------------------------------------------------------------------------- +Rel : Vect n Type -> Type +Rel ts = Fun ts Type + +liftRel : (ts : Vect n Type) -> (p : Rel ts) -> (Type -> Type) -> Type +liftRel [] p f = f p +liftRel (t :: ts) p f = (x : t) -> liftRel ts (p x) f diff --git a/libs/base/Data/ZZ.idr b/libs/base/Data/ZZ.idr --- a/libs/base/Data/ZZ.idr +++ b/libs/base/Data/ZZ.idr @@ -67,7 +67,7 @@ fromInt : Integer -> ZZ fromInt n = if n < 0 - then NegS $ fromInteger {a=Nat} (-n - 1) + then NegS $ fromInteger {a=Nat} ((-n) - 1) else Pos $ fromInteger {a=Nat} n instance Cast Nat ZZ where diff --git a/libs/base/Decidable/Decidable.idr b/libs/base/Decidable/Decidable.idr --- a/libs/base/Decidable/Decidable.idr +++ b/libs/base/Decidable/Decidable.idr @@ -1,24 +1,22 @@ module Decidable.Decidable +import Data.Rel + %access public -------------------------------------------------------------------------------- -- Typeclass for decidable n-ary Relations -------------------------------------------------------------------------------- -{- -This can't work yet! The class parameters must appear in the method type -signatures otherwise when defining the instances class resolution doesn't -have any clues... - -using (t : Type) - class Rel (p : t) where - total liftRel : (Type -> Type) -> Type +-- Note: Instance resolution for Decidable is likely to not work in the REPL +-- at the moment. +class Decidable (ts : Vect k Type) (p : Rel ts) where + total decide : liftRel ts p Dec - class (Rel p) => Decidable (p : t) where - total decide : liftRel Dec +-- 'No such variable {k506}' +--decision : Decidable ts p => (ts : Vect k Type) -> (p : Rel ts) -> liftRel ts p Dec +--decision ts p = decide {ts} {p} using (P : Type, p : P) data Given : Dec P -> Type where always : Given (Yes p) --} diff --git a/libs/base/Decidable/Order.idr b/libs/base/Decidable/Order.idr --- a/libs/base/Decidable/Order.idr +++ b/libs/base/Decidable/Order.idr @@ -1,13 +1,10 @@ module Decidable.Order -%access public - -{- -Doesn't work yet, see note in Decidable.idr - import Decidable.Decidable import Decidable.Equality +%access public + -------------------------------------------------------------------------------- -- Utility Lemmas -------------------------------------------------------------------------------- @@ -74,14 +71,8 @@ | 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 +instance Decidable [Nat,Nat] NatLTE where decide = decideNatLTE lte : (m : Nat) -> (n : Nat) -> Dec (NatLTE m n) -lte m n = decide {p = NatLTE} m n - --} - +lte m n = decide {ts = [Nat,Nat]} {p = NatLTE} m n diff --git a/libs/base/Language/Reflection.idr b/libs/base/Language/Reflection.idr --- a/libs/base/Language/Reflection.idr +++ b/libs/base/Language/Reflection.idr @@ -10,6 +10,7 @@ -- ^ Machine chosen names | NErased -- ^ Name of somethng which is never used in scope +%name TTName n, n' implicit userSuppliedName : String -> TTName @@ -19,21 +20,24 @@ -- ^ universe variable | UVal Int -- ^ explicit universe variable +%name TTUExp uexp -- | Primitive constants -data Const = I Int | BI Nat | Fl Float | Ch Char | Str String +data Const = I Int | BI Integer | 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 +%name Const c, c' + abstract class ReflConst (a : Type) where toConst : a -> Const instance ReflConst Int where toConst x = I x -instance ReflConst Nat where +instance ReflConst Integer where toConst = BI instance ReflConst Float where @@ -71,6 +75,7 @@ -- ^ constructor with tag and number | TCon Int Int -- ^ type constructor with tag and number +%name NameType nt, nt' -- | Types annotations for bound variables in different -- binding contexts @@ -83,7 +88,7 @@ | Guess a a | PVar a | PVTy a - +%name Binder b, b' instance Functor Binder where map f (Lam x) = Lam (f x) @@ -139,6 +144,8 @@ | TType TTUExp -- ^ types +%name TT tm, tm' + -- | Raw terms without types data Raw = Var TTName | RBind TTName (Binder Raw) Raw @@ -147,6 +154,8 @@ | RForce Raw | RConstant Const +%name Raw tm, tm' + data Tactic = Try Tactic Tactic -- ^ try the first tactic and resort to the second one on failure | GoalType String Tactic @@ -158,6 +167,8 @@ -- ^ apply both tactics in sequence | Trivial -- ^ intelligently construct the proof target from the context + | Instance + -- ^ resolve a type class | Solve -- ^ infer the proof target from the context | Intros @@ -177,10 +188,12 @@ -- ^ focus a named hole | Rewrite TT -- ^ rewrite using the reflected rep. of a equality proof + | Induction TTName + -- ^ do induction on the particular expression | LetTac TTName TT -- ^ name a reflected term | LetTacTy TTName TT TT -- ^ name a reflected term and type it | Compute -- ^ normalise the context - +%name Tactic tac, tac' diff --git a/libs/base/Language/Reflection/Errors.idr b/libs/base/Language/Reflection/Errors.idr --- a/libs/base/Language/Reflection/Errors.idr +++ b/libs/base/Language/Reflection/Errors.idr @@ -2,8 +2,11 @@ import Language.Reflection -data SourceLocation = FileLoc String Int +data SourceLocation : Type where + FileLoc : (filename : String) -> (line : Int) -> (col : Int) -> SourceLocation +%name SourceLocation loc + data Err = Msg String | InternalMsg String | CantUnify Bool TT TT Err (List (TTName, TT)) Int @@ -12,16 +15,19 @@ -- unification succeed | InfiniteUnify TTName TT (List (TTName, TT)) | CantConvert TT TT (List (TTName, TT)) + | CantSolveGoal TT (List (TTName, TT)) | UnifyScope TTName TTName TT (List (TTName, TT)) | CantInferType String | NonFunctionType TT TT + | NotEquality TT TT + | TooManyArguments TTName | CantIntroduce TT | NoSuchVariable TTName | NoTypeDecl TTName | NotInjective TT TT TT | CantResolve TT | CantResolveAlts (List String) - | IncompleteTT TT + | IncompleteTerm TT | UniverseError | ProgramLineComment | Inaccessible TTName @@ -32,11 +38,17 @@ | At SourceLocation Err | Elaborating String TTName Err | ProviderError String + | LoadingFailed String Err --- | Error reports are a list of report parts -data ErrorReport = Message String - | Name TTName - | Term TT +%name Err err, e +-- | Error reports are a list of report parts +data ErrorReportPart = TextPart String + | NamePart TTName + | TermPart TT + | SubReport (List ErrorReportPart) +%name ErrorReportPart part, p -- Error reports become functions in List (String, TT) -> Err -> ErrorReport +ErrorHandler : Type +ErrorHandler = Err -> Maybe (List ErrorReportPart) diff --git a/libs/base/Language/Reflection/Utils.idr b/libs/base/Language/Reflection/Utils.idr --- a/libs/base/Language/Reflection/Utils.idr +++ b/libs/base/Language/Reflection/Utils.idr @@ -1,6 +1,7 @@ module Language.Reflection.Utils import Language.Reflection +import Language.Reflection.Errors -------------------------------------------------------- -- Tactic construction conveniences @@ -185,3 +186,74 @@ equalp Impossible Impossible = True equalp (TType u) (TType u') = u == u' equalp x y = False + +total +forget : TT -> Maybe Raw +forget tm = fe [] tm + where + atIndex : List a -> Int -> Maybe a + atIndex [] _ = Nothing + atIndex (x::xs) n = + case compare n 0 of + EQ => Just x + LT => Nothing + GT => atIndex xs (n-1) + + %assert_total + fe : List TTName -> TT -> Maybe Raw + fe env (P _ n _) = Just $ Var n + fe env (V i) = map Var (atIndex env i) + fe env (Bind n b sc) = [| RBind (pure n) (traverse (fe env) b) (fe (n::env) sc) |] + fe env (App f a) = [| RApp (fe env f) (fe env a) |] + fe env (TConst c) = Just $ RConstant c + fe env (Proj tm i) = Nothing -- runtime only, not useful for metaprogramming + fe env (TType i) = Just RType + fe env Erased = Just $ RConstant Forgot + fe env Impossible = Nothing + +instance Show Raw where + show r = my_show r + where %assert_total my_show : Raw -> String + my_show (Var n) = "Var " ++ show n + my_show (RBind n b tm) = "RBind " ++ show n ++ " " ++ show b ++ " (" ++ my_show tm ++ ")" + my_show (RApp tm tm') = "RApp " ++ my_show tm ++ " " ++ my_show tm' + my_show RType = "RType" + my_show (RForce tm) = "RForce " ++ my_show tm + my_show (RConstant c) = "RConstant " ++ show c + +instance Show SourceLocation where + show (FileLoc filename line col) = "FileLoc \"" ++ filename ++ "\" " ++ show line ++ " " ++ show col + +instance Show Err where + show (Msg x) = "Msg \"" ++ x ++ "\"" + show (InternalMsg x) = "InternalMsg \"" ++ x ++ "\"" + show (CantUnify x tm tm' err xs y) = "CantUnify " ++ show x ++ + " ( " ++ show tm ++ ") (" ++ show tm' ++ ") (" ++ show err ++ ") " ++ + show xs ++ " " ++ show y + show (InfiniteUnify n tm xs) = "InfiniteUnify " ++ show n ++ show tm ++ show xs + show (CantConvert tm tm' xs) = "CantConvert " ++ show tm ++ show tm' ++ show xs + show (CantSolveGoal tm ctxt) = "CantSolveGoal " ++ show tm ++ " " ++ show ctxt + show (UnifyScope n n' tm xs) = "UnifyScope " ++ show n ++ " " ++ show n' ++ " " ++ show tm ++ " " ++ show xs + show (CantInferType x) = "CantInferType " ++ show x + show (NonFunctionType tm tm') = "NonFunctionType " ++ show tm ++ show tm' + show (NotEquality tm tm') = "NotEquality " ++ show tm ++ " " ++ show tm' + show (TooManyArguments n) = "TooManyArguments " ++ show n + show (CantIntroduce tm) = "CantIntroduce " ++ show tm + show (NoSuchVariable n) = "NoSuchVariable " ++ show n + show (NoTypeDecl n) = "NoTypeDecl " ++ show n + show (NotInjective tm tm' x) = "NotInjective " ++ show tm ++ " " ++ show tm' + show (CantResolve tm) = "CantResolve " ++ show tm + show (CantResolveAlts xs) = "CantResolveAlts " ++ show xs + show (IncompleteTerm tm) = "IncompleteTerm " ++ show tm + show UniverseError = "UniverseError" + show ProgramLineComment = "ProgramLineComment" + show (Inaccessible n) = "Inaccessible " ++ show n + show (NonCollapsiblePostulate n) = "NonCollapsiblePostulate " ++ show n + show (AlreadyDefined n) = "AlreadyDefined " ++ show n + show (ProofSearchFail err) = "ProofSearchFail " ++ show err + show (NoRewriting tm) = "NoRewriting " ++ show tm + show (At loc err) = "At " ++ show loc ++ " " ++ show err + show (Elaborating x n err) = "Elaborating " ++ show x ++ " " ++ show x ++ " " ++ show n ++ " (" ++ show err ++ ")" + show (ProviderError x) = "ProviderError \"" ++ show x ++ "\"" + show (LoadingFailed x err) = "LoadingFailed " ++ show x ++ " (" ++ show err ++ ")" + diff --git a/libs/base/Makefile b/libs/base/Makefile --- a/libs/base/Makefile +++ b/libs/base/Makefile @@ -1,17 +1,17 @@ IDRIS := idris -build: .PHONY +build: $(IDRIS) --build base.ipkg install: $(IDRIS) --install base.ipkg -clean: .PHONY +clean: $(IDRIS) --clean base.ipkg rebuild: clean build -linecount: .PHONY +linecount: find . -name '*.idr' | xargs wc -l -.PHONY: +.PHONY: build install clean rebuild linecount diff --git a/libs/base/Providers.idr b/libs/base/Providers.idr --- a/libs/base/Providers.idr +++ b/libs/base/Providers.idr @@ -3,3 +3,17 @@ public data Provider a = Provide a | Error String +-- instances +instance Functor Provider where + map f (Provide a) = Provide (f a) + map f (Error err) = Error err + +instance Applicative Provider where + (Provide f) <$> (Provide x) = Provide (f x) + (Provide f) <$> (Error err) = Error err + (Error err) <$> _ = Error err + pure = Provide + +instance Monad Provider where + (Provide x) >>= f = f x + (Error err) >>= _ = Error err diff --git a/libs/base/Syntax/PreorderReasoning.idr b/libs/base/Syntax/PreorderReasoning.idr new file mode 100644 --- /dev/null +++ b/libs/base/Syntax/PreorderReasoning.idr @@ -0,0 +1,15 @@ +module Syntax.PreorderReasoning + +-- QED is first to get the precedence to work out. It's just refl with an explicit argument. +syntax [expr] "QED" = qed expr +-- foo ={ prf }= bar ={ prf' }= fnord QED +-- is a proof that foo is related to fnord, with the intermediate step being bar, justified by prf and prf' +syntax [from] "={" [prf] "}=" [to] = step from prf to + +namespace Equal + using (a : Type, x : a, y : a, z : a) + qed : (x : a) -> x = x + qed x = the (x = x) refl + step : (x : a) -> x = y -> (y = z) -> x = z + step x refl refl = refl + diff --git a/libs/base/System/Concurrency/Raw.idr b/libs/base/System/Concurrency/Raw.idr --- a/libs/base/System/Concurrency/Raw.idr +++ b/libs/base/System/Concurrency/Raw.idr @@ -14,7 +14,7 @@ [FPtr, FPtr, FAny a] FUnit) prim__vm dest val checkMsgs : IO Bool -checkMsgs = do msgs <- mkForeign (FFun "idris_checkMessage" +checkMsgs = do msgs <- mkForeign (FFun "idris_checkMessages" [FPtr] FInt) prim__vm return (intToBool msgs) diff --git a/libs/base/Uninhabited.idr b/libs/base/Uninhabited.idr --- a/libs/base/Uninhabited.idr +++ b/libs/base/Uninhabited.idr @@ -10,3 +10,6 @@ instance Uninhabited (Z = S n) where uninhabited refl impossible +-- | Use an absurd assumption to discharge a proof obligation +absurd : Uninhabited t => t -> a +absurd t = FalseElim (uninhabited t) diff --git a/libs/base/base.ipkg b/libs/base/base.ipkg --- a/libs/base/base.ipkg +++ b/libs/base/base.ipkg @@ -16,15 +16,21 @@ Language.Reflection, Language.Reflection.Utils, Language.Reflection.Errors, - Data.Morphisms, - Data.Bits, Data.Mod2, + Syntax.PreorderReasoning, + + Data.Morphisms, + Data.Bits, Data.Mod2, Data.ZZ, Data.Sign, Data.SortedMap, Data.SortedSet, Data.BoundedList, Data.Vect, Data.HVect, Data.Vect.Quantifiers, - Data.Floats, Data.Complex, Data.Heap, + Data.Floats, Data.Complex, Data.Heap, Data.Fun, + Data.Rel, Data.Buffer, + Control.Isomorphism, Control.Isomorphism.Primitives, Control.Monad.Identity, Control.Monad.RWS, Control.Monad.State, Control.Monad.Writer, Control.Monad.Reader, Control.Category, Control.Arrow, Control.Catchable, Control.IOExcept + + diff --git a/libs/effects/Effect/Memory.idr b/libs/effects/Effect/Memory.idr --- a/libs/effects/Effect/Memory.idr +++ b/libs/effects/Effect/Memory.idr @@ -80,8 +80,8 @@ 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) (Initialize {i} c size _) k + = ioe_lift (do_memset ptr i c size) $> k (CH ptr) () handle (CH ptr) (Free) k = ioe_lift (do_free ptr) $> k () () handle (CH ptr) (Peek offset size _) k @@ -165,4 +165,5 @@ 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 () + return () + diff --git a/libs/effects/Effect/Monad.idr b/libs/effects/Effect/Monad.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effect/Monad.idr @@ -0,0 +1,21 @@ +module Effect.Monad + +import Effects + +-- Eff is a monad too, so we can happily use it in a monad transformer. + +using (xs : List EFFECT, m : Type -> Type) + instance Functor (EffM m xs xs) where + map f prog = do t <- prog + value (f t) + + instance Applicative (EffM m xs xs) where + pure = value + (<$>) f a = do f' <- f + a' <- a + value (f' a') + + instance Monad (EffM m xs xs) where + (>>=) = ebind + + diff --git a/libs/effects/Effects.idr b/libs/effects/Effects.idr --- a/libs/effects/Effects.idr +++ b/libs/effects/Effects.idr @@ -10,6 +10,7 @@ Effect : Type Effect = Type -> Type -> Type -> Type +%error_reverse data EFFECT : Type where MkEff : Type -> Effect -> EFFECT @@ -62,20 +63,37 @@ ---- The Effect EDSL itself ---- -- some proof automation -findEffElem : Nat -> List (TTName, Binder TT) -> TT -> Tactic -- Nat is maximum search depth -findEffElem Z 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 ctxt goal))) -findSubList : Nat -> List (TTName, Binder TT) -> TT -> Tactic -findSubList Z 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 ctxt goal)) +%reflection +reflectListEffElem : List a -> Tactic +reflectListEffElem [] = Refine "Here" `Seq` Solve +reflectListEffElem (x :: xs) + = Try (Refine "Here" `Seq` Solve) + (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs)) +-- TMP HACK! FIXME! +-- The evaluator needs a 'function case' to know its a reflection function +-- until we propagate that information! Without this, the _ case won't get +-- matched. +reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve +reflectListEffElem _ = Refine "Here" `Seq` Solve +%reflection +reflectSubList : List a -> Tactic +reflectSubList [] = Refine "SubNil" `Seq` Solve +reflectSubList (x :: xs) + = Try (Refine "subListId" `Seq` Solve) + (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs)) + (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs))) +reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve +reflectSubList _ = Refine "subListId" `Seq` Solve + +%reflection +reflectEff : (P : Type) -> Tactic +reflectEff (EffElem m a xs) + = reflectListEffElem xs `Seq` Solve +reflectEff (SubList xs ys) + = reflectSubList ys `Seq` Solve + 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 @@ -135,46 +153,47 @@ -- Eff : List (EFFECT m) -> Type -> Type implicit -lift' : {default tactics { applyTactic findSubList 20; solve; } +lift' : EffM m ys ys' t -> + {default tactics { byReflection reflectEff; } prf : SubList ys xs} -> - EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t -lift' {prf} e = lift prf e + EffM m xs (updateWith ys' xs prf) t +lift' e {prf} = lift prf e implicit effect' : {a, b: _} -> {e : Effect} -> - {default tactics { applyTactic findEffElem 20; solve; } - prf : EffElem e a xs} -> (eff : e a b t) -> + {default tactics { byReflection reflectEff; } + prf : EffElem e a xs} -> EffM m xs (updateResTy xs prf eff) t -effect' {prf} e = effect prf e +effect' e {prf} = effect prf e -- For making proofs implicitly for 'test' and 'test_lbl' syntax if_valid then [e] else [t] = - test (tactics { applyTactic findEffElem 20; solve; }) t e + test (tactics { byReflection reflectEff; }) t e syntax if_valid [lbl] then [e] else [t] = - test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e + test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e syntax if_error then [t] else [e] = - test (tactics { applyTactic findEffElem 20; solve; }) t e + test (tactics { byReflection reflectEff; }) t e syntax if_error [lbl] then [t] else [e] = - test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e + test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e -- These may read better in some contexts syntax if_right then [e] else [t] = - test (tactics { applyTactic findEffElem 20; solve; }) t e + test (tactics { byReflection reflectEff; }) t e syntax if_right [lbl] then [e] else [t] = - test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e + test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e syntax if_left then [t] else [e] = - test (tactics { applyTactic findEffElem 20; solve; }) t e + test (tactics { byReflection reflectEff; }) t e syntax if_left [lbl] then [t] else [e] = - test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e + test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e -- for 'do' notation diff --git a/libs/effects/Makefile b/libs/effects/Makefile --- a/libs/effects/Makefile +++ b/libs/effects/Makefile @@ -1,9 +1,9 @@ IDRIS := idris -build: .PHONY +build: $(IDRIS) --build effects.ipkg -clean: .PHONY +clean: $(IDRIS) --clean effects.ipkg install: @@ -11,4 +11,4 @@ rebuild: clean build -.PHONY: +.PHONY: build clean install rebuild diff --git a/libs/effects/effects.ipkg b/libs/effects/effects.ipkg --- a/libs/effects/effects.ipkg +++ b/libs/effects/effects.ipkg @@ -4,5 +4,5 @@ modules = Effects, Effect.Exception, Effect.File, Effect.State, Effect.Random, Effect.StdIO, Effect.Select, - Effect.Memory + Effect.Memory, Effect.Monad diff --git a/libs/javascript/Makefile b/libs/javascript/Makefile --- a/libs/javascript/Makefile +++ b/libs/javascript/Makefile @@ -1,14 +1,14 @@ IDRIS := idris -build: .PHONY +build: $(IDRIS) --build javascript.ipkg install: $(IDRIS) --install javascript.ipkg -clean: .PHONY +clean: $(IDRIS) --clean javascript.ipkg rebuild: clean build -.PHONY: +.PHONY: build install clean rebuild diff --git a/libs/neweffects/Effect/Default.idr b/libs/neweffects/Effect/Default.idr new file mode 100644 --- /dev/null +++ b/libs/neweffects/Effect/Default.idr @@ -0,0 +1,44 @@ +module Default + +class Default a where + default : a + +instance Default Int where + default = 0 + +instance Default Integer where + default = 0 + +instance Default Float where + default = 0 + +instance Default Nat where + default = 0 + +instance Default Char where + default = '\0' + +instance Default String where + default = "" + +instance Default Bool where + default = False + +instance Default () where + default = () + +instance (Default a, Default b) => Default (a, b) where + default = (default, default) + +instance Default (Maybe a) where + default = Nothing + +instance Default (List a) where + default = [] + +instance Default a => Default (Vect n a) where + default = mkDef _ where + mkDef : (n : Nat) -> Vect n a + mkDef Z = [] + mkDef (S k) = default :: mkDef k + diff --git a/libs/neweffects/Effect/Exception.idr b/libs/neweffects/Effect/Exception.idr new file mode 100644 --- /dev/null +++ b/libs/neweffects/Effect/Exception.idr @@ -0,0 +1,39 @@ +module Effect.Exception + +import Effects +import System +import Control.IOExcept + +data Exception : Type -> Effect where + Raise : a -> { () } Exception a b + +instance Handler (Exception a) Maybe where + handle _ (Raise e) k = Nothing + +instance Show a => Handler (Exception a) IO where + handle _ (Raise e) k = do print e + believe_me (exit 1) + +instance Handler (Exception a) (IOExcept a) where + handle _ (Raise e) k = ioM (return (Left e)) + +instance Handler (Exception a) (Either a) where + handle _ (Raise e) k = Left e + +EXCEPTION : Type -> EFFECT +EXCEPTION t = MkEff () (Exception t) + +raise : a -> { [EXCEPTION a ] } Eff m b +raise err = Raise err + + + + + + +-- TODO: Catching exceptions mid program? +-- probably need to invoke a new interpreter + +-- possibly add a 'handle' to the Eff language so that an alternative +-- handler can be introduced mid interpretation? + diff --git a/libs/neweffects/Effect/File.idr b/libs/neweffects/Effect/File.idr new file mode 100644 --- /dev/null +++ b/libs/neweffects/Effect/File.idr @@ -0,0 +1,62 @@ +module Effect.File + +import Effects +import Control.IOExcept + +data OpenFile : Mode -> Type where + FH : File -> OpenFile m + +openOK : Mode -> Bool -> Type +openOK m True = OpenFile m +openOK m False = () + +data FileIO : Effect where + Open : String -> (m : Mode) -> + {() ==> {res} if res then OpenFile m else ()} FileIO Bool + Close : {OpenFile m ==> ()} FileIO () + + ReadLine : {OpenFile Read} FileIO String + WriteLine : String -> {OpenFile Write} FileIO () + EOF : {OpenFile Read} FileIO Bool + +instance Handler FileIO IO where + handle () (Open fname m) k = do h <- openFile fname m + valid <- validFile h + if valid then k True (FH h) + else k False () + handle (FH h) Close k = do closeFile h + k () () + handle (FH h) ReadLine k = do str <- fread h + k str (FH h) + handle (FH h) (WriteLine str) k = do fwrite h str + k () (FH h) + handle (FH h) EOF k = do e <- feof h + k e (FH h) + +FILE_IO : Type -> EFFECT +FILE_IO t = MkEff t FileIO + +open : Handler FileIO e => + String -> (m : Mode) -> + { [FILE_IO ()] ==> [FILE_IO (if result then OpenFile m else ())] } Eff e Bool +open f m = Open f m + +close : Handler FileIO e => + { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff e () +close = Close + +readLine : Handler FileIO e => + { [FILE_IO (OpenFile Read)] } Eff e String +readLine = ReadLine + +writeLine : Handler FileIO e => + String -> { [FILE_IO (OpenFile Write)] } Eff e () +writeLine str = WriteLine str + +eof : Handler FileIO e => + { [FILE_IO (OpenFile Read)] } Eff e Bool +eof = EOF + + + + diff --git a/libs/neweffects/Effect/Memory.idr b/libs/neweffects/Effect/Memory.idr new file mode 100644 --- /dev/null +++ b/libs/neweffects/Effect/Memory.idr @@ -0,0 +1,175 @@ +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 () () (\v => MemoryChunk n 0) + Free : RawMemory () (MemoryChunk n i) (\v => ()) + Initialize : Bits8 -> + (size : Nat) -> + so (i + size <= n) -> + RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (i + size)) + Peek : (offset : Nat) -> + (size : Nat) -> + so (offset + size <= i) -> + RawMemory (Vect size Bits8) + (MemoryChunk n i) (\v => MemoryChunk n i) + Poke : (offset : Nat) -> + (Vect size Bits8) -> + so (offset <= i && offset + size <= n) -> + RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size))) + Move : (src : MemoryChunk src_size src_init) -> + (dst_offset : Nat) -> + (src_offset : Nat) -> + (size : Nat) -> + so (dst_offset <= dst_init && dst_offset + size <= dst_size) -> + so (src_offset + size <= src_init) -> + RawMemory () (MemoryChunk dst_size dst_init) + (\v => MemoryChunk dst_size (max dst_init (dst_offset + size))) + GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i) + +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) (fromInteger $ 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, FByte, FInt] FUnit) + ptr (fromInteger $ cast offset) c (fromInteger $ 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 (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size) + +private +do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8) +do_peek _ _ Z = return (Prelude.Vect.Nil) +do_peek ptr offset (S n) + = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FByte) ptr (fromInteger $ cast offset) + bs <- do_peek ptr (S offset) n + Prelude.Monad.return (Prelude.Vect.(::) b bs) + +private +do_poke : Ptr -> Nat -> Vect size Bits8 -> IO () +do_poke _ _ [] = return () +do_poke ptr offset (b::bs) + = do mkForeign (FFun "idris_poke" [FPtr, FInt, FByte] FUnit) ptr (fromInteger $ 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 {i} c size _) k + = ioe_lift (do_memset ptr i 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 res (CH ptr) + 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) -> + Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)]) +allocate size = Allocate size + +initialize : {i : Nat} -> + {n : Nat} -> + Bits8 -> + (size : Nat) -> + so (i + size <= n) -> + Eff m () [RAW_MEMORY (MemoryChunk n i)] + (\v => [RAW_MEMORY (MemoryChunk n (i + size))]) +initialize c size prf = Initialize c size prf + +free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()]) +free = Free + +peek : {i : Nat} -> + (offset : Nat) -> + (size : Nat) -> + so (offset + size <= i) -> + { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8) +peek offset size prf = Peek offset size prf + +poke : {n : Nat} -> + {i : Nat} -> + (offset : Nat) -> + Vect size Bits8 -> + so (offset <= i && offset + size <= n) -> + Eff m () [RAW_MEMORY (MemoryChunk n i)] + (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))]) +poke offset content prf = Poke offset content prf + +private +getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (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) -> + Eff m () [RAW_MEMORY (MemoryChunk dst_size dst_init)] + (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))]) +move' src_ptr dst_offset src_offset size dst_bounds src_bounds + = 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) -> + Eff m () + [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init) + , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] + (\v => + [ 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 () + diff --git a/libs/neweffects/Effect/Monad.idr b/libs/neweffects/Effect/Monad.idr new file mode 100644 --- /dev/null +++ b/libs/neweffects/Effect/Monad.idr @@ -0,0 +1,21 @@ +module Effect.Monad + +import Effects + +-- Eff is a monad too, so we can happily use it in a monad transformer. + +using (xs : List EFFECT, m : Type -> Type) + instance Functor (\a => EffM m a xs (\v => xs)) where + map f prog = do t <- prog + value (f t) + + instance Applicative (\a => EffM m a xs (\v => xs)) where + pure = value + (<$>) f a = do f' <- f + a' <- a + value (f' a') + + instance Monad (\a => Eff m a xs (\v => xs)) where + (>>=) = Effects.(>>=) + + diff --git a/libs/neweffects/Effect/Random.idr b/libs/neweffects/Effect/Random.idr new file mode 100644 --- /dev/null +++ b/libs/neweffects/Effect/Random.idr @@ -0,0 +1,25 @@ +module Effect.Random + +import Effects + +data Random : Effect where + getRandom : { Integer } Random Integer + setSeed : Integer -> { Integer } Random () + +using (m : Type -> Type) + instance Handler Random m where + handle seed getRandom k + = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in + k seed' seed' + handle seed (setSeed n) k = k () n + +RND : EFFECT +RND = MkEff Integer Random + +rndInt : Integer -> Integer -> { [RND] } Eff m Integer +rndInt lower upper = do v <- getRandom + return (v `prim__sremBigInt` (upper - lower) + lower) + +srand : Integer -> { [RND] } Eff m () +srand n = setSeed n + diff --git a/libs/neweffects/Effect/Select.idr b/libs/neweffects/Effect/Select.idr new file mode 100644 --- /dev/null +++ b/libs/neweffects/Effect/Select.idr @@ -0,0 +1,23 @@ +module Effect.Select + +import Effects + +data Selection : Effect where + Select : List a -> { () } Selection a + +instance Handler Selection Maybe where + handle _ (Select xs) k = tryAll xs where + tryAll [] = Nothing + tryAll (x :: xs) = case k x () of + Nothing => tryAll xs + Just v => Just v + +instance Handler Selection List where + handle r (Select xs) k = concatMap (\x => k x r) xs + +SELECT : EFFECT +SELECT = MkEff () Selection + +select : List a -> { [SELECT] } Eff m a +select xs = Select xs + diff --git a/libs/neweffects/Effect/State.idr b/libs/neweffects/Effect/State.idr new file mode 100644 --- /dev/null +++ b/libs/neweffects/Effect/State.idr @@ -0,0 +1,40 @@ +module Effect.State + +import Effects + +%access public + +data State : Effect where + Get : { a } State a + Put : b -> { a ==> b } State () + +using (m : Type -> Type) + instance Handler State m where + handle st Get k = k st st + handle st (Put n) k = k () n + +STATE : Type -> EFFECT +STATE t = MkEff t State + +get : { [STATE x] } Eff m x +get = Get + +put : x -> { [STATE x] } Eff m () +put val = Put val + +putM : y -> { [STATE x] ==> [STATE y] } Eff m () +putM val = Put val + +update : (x -> x) -> { [STATE x] } Eff m () +update f = put (f !get) + +updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff m () +updateM f = putM (f !get) + +locally : x -> ({ [STATE x] } Eff m t) -> { [STATE y] } Eff m t +locally newst prog = do st <- get + putM newst + val <- prog + putM st + return val + diff --git a/libs/neweffects/Effect/StdIO.idr b/libs/neweffects/Effect/StdIO.idr new file mode 100644 --- /dev/null +++ b/libs/neweffects/Effect/StdIO.idr @@ -0,0 +1,37 @@ +module Effect.StdIO + +import Effects +import Control.IOExcept + +data StdIO : Effect where + PutStr : String -> { () } StdIO () + GetStr : { () } StdIO String + PutCh : Char -> { () } StdIO () + GetCh : { () } StdIO Char + +instance Handler StdIO IO where + handle () (PutStr s) k = do putStr s; k () () + handle () GetStr k = do x <- getLine; k x () + handle () (PutCh c) k = do putChar c; k () () + handle () GetCh k = do x <- getChar; k x () + +--- The Effect and associated functions + +STDIO : EFFECT +STDIO = MkEff () StdIO + +putStr : Handler StdIO e => String -> { [STDIO] } Eff e () +putStr s = PutStr s + +putChar : Handler StdIO e => Char -> { [STDIO] } Eff e () +putChar c = PutCh c + +putStrLn : Handler StdIO e => String -> { [STDIO] } Eff e () +putStrLn s = putStr (s ++ "\n") + +getStr : Handler StdIO e => { [STDIO] } Eff e String +getStr = GetStr + +getChar : Handler StdIO e => { [STDIO] } Eff e Char +getChar = GetCh + diff --git a/libs/neweffects/Effects.idr b/libs/neweffects/Effects.idr new file mode 100644 --- /dev/null +++ b/libs/neweffects/Effects.idr @@ -0,0 +1,291 @@ +module Effects + +import Language.Reflection +import Control.Catchable +import Effect.Default + +%access public + +---- Effects + +Effect : Type +Effect = (x : Type) -> Type -> (x -> Type) -> Type + +%error_reverse +data EFFECT : Type where + MkEff : Type -> Effect -> EFFECT + +class Handler (e : Effect) (m : Type -> Type) where + handle : res -> (eff : e t res resk) -> + ((x : t) -> resk x -> m a) -> m a + +-- A bit of syntactic sugar ('syntax' is not very flexible so we only go +-- up to a small number of parameters...) + +syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff] + = eff inst (\b => outst) +syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst) +syntax "{" [inst] "}" [eff] = eff inst (\result => inst) + +---- Properties and proof construction + +using (xs : List a, ys : List a) + data SubList : List a -> List a -> Type where + SubNil : SubList {a} [] [] + Keep : SubList xs ys -> SubList (x :: xs) (x :: ys) + Drop : SubList xs ys -> SubList xs (x :: ys) + + subListId : SubList xs xs + subListId {xs = Nil} = SubNil + subListId {xs = x :: xs} = Keep subListId + +namespace Env + 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 : Effect -> Type -> + List EFFECT -> Type where + Here : EffElem x a (MkEff a x :: xs) + There : EffElem x a xs -> EffElem x a (y :: xs) + +-- make an environment corresponding to a sub-list +dropEnv : Env m ys -> SubList xs ys -> Env m xs +dropEnv [] SubNil = [] +dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest +dropEnv (v :: vs) (Drop rest) = dropEnv vs rest + +updateWith : (ys' : List a) -> (xs : List a) -> + SubList ys xs -> List a +updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest +updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest +updateWith [] [] SubNil = [] +updateWith (y :: ys) [] SubNil = y :: ys +updateWith [] (x :: xs) (Keep rest) = [] + +-- put things back, replacing old with new in the sub-environment +rebuildEnv : Env m ys' -> (prf : SubList ys xs) -> + Env m xs -> Env m (updateWith ys' xs prf) +rebuildEnv [] SubNil env = env +rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env +rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env +rebuildEnv (x :: xs) SubNil [] = x :: xs + +---- The Effect EDSL itself ---- + +-- some proof automation + +%reflection +reflectListEffElem : List a -> Tactic +reflectListEffElem [] = Refine "Here" `Seq` Solve +reflectListEffElem (x :: xs) + = Try (Refine "Here" `Seq` Solve) + (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs)) +-- TMP HACK! FIXME! +-- The evaluator needs a 'function case' to know its a reflection function +-- until we propagate that information! Without this, the _ case won't get +-- matched. +reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve +reflectListEffElem _ = Refine "Here" `Seq` Solve + +%reflection +reflectSubList : List a -> Tactic +reflectSubList [] = Refine "subListId" `Seq` Solve +reflectSubList (x :: xs) + = Try (Refine "subListId" `Seq` Solve) + (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs)) + (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs))) +reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve +reflectSubList _ = Refine "subListId" `Seq` Solve + +%reflection +reflectDefaultList : List a -> Tactic +reflectDefaultList [] = Refine "enil" `Seq` Solve +reflectDefaultList (x :: xs) + = Refine "econs" `Seq` + (Solve `Seq` + (Instance `Seq` + (Refine "default" `Seq` + (Solve `Seq` + (Instance `Seq` + (reflectDefaultList xs)))))) +reflectDefaultList (x ++ y) = Refine "Nil" `Seq` Solve +reflectDefaultList _ = Refine "Nil" `Seq` Solve + +%reflection +reflectEff : (P : Type) -> Tactic +reflectEff (EffElem m a xs) + = reflectListEffElem xs `Seq` Solve +reflectEff (SubList xs ys) + = reflectSubList ys `Seq` Solve +reflectEff (Env m xs) + = reflectDefaultList xs `Seq` Solve + +updateResTy : (val : t) -> + (xs : List EFFECT) -> EffElem e a xs -> e t a b -> + List EFFECT +updateResTy {b} val (MkEff a e :: xs) Here n = (MkEff (b val) e) :: xs +updateResTy val (x :: xs) (There p) n = x :: updateResTy val xs p n + +-- updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type -> +-- List EFFECT +-- updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs +-- updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b + +infix 5 :::, :-, := + +data LRes : lbl -> Type -> Type where + (:=) : (x : lbl) -> res -> LRes x res + +(:::) : lbl -> EFFECT -> EFFECT +(:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e + +using (lbl : Type) + instance Default a => Default (LRes lbl a) where + default = lbl := default + +private +unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x] +unlabel {m} {x = MkEff a eff} [l := v] = [v] + +private +relabel : (l : ty) -> Env m xs -> Env m (map (\x => l ::: x) xs) +relabel {xs = []} l [] = [] +relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs + +-- the language of Effects + +data Eff : (m : Type -> Type) -> + (x : Type) -> + List EFFECT -> (x -> List EFFECT) -> Type where + value : a -> Eff m a xs (\v => xs) + ebind : Eff m a xs xs' -> + ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs'' + effect : (prf : EffElem e a xs) -> + (eff : e t a b) -> + Eff m t xs (\v => updateResTy v xs prf eff) + + lift : (prf : SubList ys xs) -> + Eff m t ys ys' -> Eff m t xs (\v => updateWith (ys' v) xs prf) + new : Handler e m => + res -> + Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) -> + Eff m a xs (\v => xs') + catch : Catchable m err => + Eff m a xs xs' -> (err -> Eff m a xs xs') -> + Eff m a xs xs' + + (:-) : (l : ty) -> + Eff m t [x] xs' -> -- [x] (\v => xs) -> + Eff m t [l ::: x] (\v => map (l :::) (xs' v)) + +(>>=) : Eff m a xs xs' -> + ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs'' +(>>=) = ebind + +implicit +lift' : Eff m t ys ys' -> + {default tactics { byReflection reflectEff; } + prf : SubList ys xs} -> + Eff m t xs (\v => updateWith (ys' v) xs prf) +lift' e {prf} = lift prf e + +implicit +effect' : {a, b: _} -> {e : Effect} -> + (eff : e t a b) -> + {default tactics { byReflection reflectEff; } + prf : EffElem e a xs} -> + Eff m t xs (\v => updateResTy v xs prf eff) +effect' e {prf} = effect prf e + +return : a -> Eff m a xs (\v => xs) +return x = value x + +-- for idiom brackets + +infixl 2 <$> + +pure : a -> Eff m a xs (\v => xs) +pure = value + +(<$>) : Eff m (a -> b) xs (\v => xs) -> + Eff m a xs (\v => xs) -> Eff m b xs (\v => xs) +(<$>) prog v = do fn <- prog + arg <- v + return (fn arg) + +-- an interpreter + +private +execEff : Env m xs -> (p : EffElem e res xs) -> + (eff : e a res resk) -> + ((v : a) -> Env m (updateResTy v xs p eff) -> m t) -> m t +execEff (val :: env) Here eff' k + = handle val eff' (\v, res => k v (res :: env)) +execEff (val :: env) (There p) eff k + = execEff env p eff (\v, env' => k v (val :: env')) + +-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state +-- updates can be propagated even through failing computations? + +eff : Env m xs -> Eff m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b +eff env (value x) k = k x env +eff env (prog `ebind` c) k + = eff env prog (\p', env' => eff env' (c p') k) +eff env (effect prf effP) k = execEff env prf effP k +eff env (lift prf effP) k + = let env' = dropEnv env prf in + eff env' effP (\p', envk => k p' (rebuildEnv envk prf env)) +eff env (new r prog) k + = let env' = r :: env in + eff env' prog (\p' => \ (v :: envk) => k p' envk) +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 env in + eff env' prog (\p', envk => k p' (relabel l envk)) + +-- yuck :) Haven't got type class instances working nicely in tactic +-- proofs yet, so just brute force it. +syntax MkDefaultEnv = (| [], [default], [default, default], + [default, default, default], + [default, default, default, default], + [default, default, default, default, default], + [default, default, default, default, default, default], + [default, default, default, default, default, default, default], + [default, default, default, default, default, default, default, default] |) + +run : Applicative m => {default MkDefaultEnv env : Env m xs} -> Eff m a xs xs' -> m a +run {env} prog = eff env prog (\r, env => pure r) + +runPure : {default MkDefaultEnv env : Env id xs} -> Eff id a xs xs' -> a +runPure {env} prog = eff env prog (\r, env => r) + +runInit : Applicative m => Env m xs -> Eff m a xs xs' -> m a +runInit env prog = eff env prog (\r, env => pure r) + +runPureInit : Env id xs -> Eff id a xs xs' -> a +runPureInit env prog = eff env prog (\r, env => r) + +runWith : (a -> m a) -> Env m xs -> Eff m a xs xs' -> m a +runWith inj env prog = eff env prog (\r, env => inj r) + +runEnv : Applicative m => Env m xs -> Eff m a xs xs' -> + m (x : a ** Env m (xs' x)) +runEnv env prog = eff env prog (\r, env => pure (r ** env)) + +-- some higher order things + +mapE : Applicative m => (a -> {xs} Eff m b) -> List a -> {xs} Eff m (List b) +mapE f [] = pure [] +mapE f (x :: xs) = [| f x :: mapE f xs |] + +when : Applicative m => Bool -> ({xs} Eff m ()) -> {xs} Eff m () +when True e = e +when False e = pure () + diff --git a/libs/neweffects/Makefile b/libs/neweffects/Makefile new file mode 100644 --- /dev/null +++ b/libs/neweffects/Makefile @@ -0,0 +1,14 @@ +IDRIS := idris + +build: + $(IDRIS) --build neweffects.ipkg + +clean: + $(IDRIS) --clean neweffects.ipkg + +install: + $(IDRIS) --install neweffects.ipkg + +rebuild: clean build + +.PHONY: build clean install rebuild diff --git a/libs/neweffects/neweffects.ipkg b/libs/neweffects/neweffects.ipkg new file mode 100644 --- /dev/null +++ b/libs/neweffects/neweffects.ipkg @@ -0,0 +1,9 @@ +package neweffects + +opts = "--nobasepkgs -i ../prelude -i ../base" +modules = Effects, Effect.Default, + + Effect.Exception, Effect.File, Effect.State, + Effect.Random, Effect.StdIO, Effect.Select, + Effect.Memory + diff --git a/libs/prelude/Builtins.idr b/libs/prelude/Builtins.idr --- a/libs/prelude/Builtins.idr +++ b/libs/prelude/Builtins.idr @@ -1,3 +1,5 @@ +%unqualified + %access public %default total @@ -12,6 +14,9 @@ FalseElim : _|_ -> a +-- For 'symbol syntax. 'foo becomes Symbol_ "foo" +data Symbol_ : String -> Type where + -- ------------------------------------------------------ [ For rewrite tactic ] replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y replace refl prf = prf @@ -33,6 +38,16 @@ trace_malloc : a -> a trace_malloc x = x -- compiled specially + +-- Assert to the totality checker than y is always structureally smaller than +-- x (which is typically a pattern argument) +assert_smaller : a -> a -> a +assert_smaller x y = y + +-- Assert to the totality checker than the given expression will always +-- terminate. +assert_total : a -> a +assert_total x = x abstract %assert_total -- need to pretend believe_me : a -> b -- compiled specially as id, use with care! diff --git a/libs/prelude/Decidable/Equality.idr b/libs/prelude/Decidable/Equality.idr --- a/libs/prelude/Decidable/Equality.idr +++ b/libs/prelude/Decidable/Equality.idr @@ -1,6 +1,7 @@ module Decidable.Equality import Builtins +import Prelude.Basics import Prelude.Either import Prelude.List import Prelude.Vect @@ -152,7 +153,7 @@ decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil) decEq (x :: xs) (y :: ys) with (decEq x y) decEq (x :: xs) (x :: ys) | Yes refl with (decEq xs ys) - decEq (x :: xs) (x :: xs) | (Yes refl) | (Yes refl) = Yes refl -- maybe another yes refl + decEq (x :: xs) (x :: xs) | (Yes refl) | (Yes refl) = Yes refl decEq (x :: xs) (x :: ys) | (Yes refl) | (No p) = No (\eq => lemma_x_eq_xs_neq refl p eq) decEq (x :: xs) (y :: ys) | No p with (decEq xs ys) decEq (x :: xs) (y :: xs) | (No p) | (Yes refl) = No (\eq => lemma_x_neq_xs_eq p refl eq) @@ -213,4 +214,13 @@ instance DecEq Float where decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl) else No (really_believe_me _|_) + +-------------------------------------------------------------------------------- +-- String +-------------------------------------------------------------------------------- + +instance DecEq String where + decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl) + else No (really_believe_me _|_) + diff --git a/libs/prelude/IO.idr b/libs/prelude/IO.idr --- a/libs/prelude/IO.idr +++ b/libs/prelude/IO.idr @@ -1,3 +1,5 @@ +%unqualified + import Prelude.List %access public diff --git a/libs/prelude/Makefile b/libs/prelude/Makefile --- a/libs/prelude/Makefile +++ b/libs/prelude/Makefile @@ -1,17 +1,17 @@ IDRIS := idris -build: .PHONY +build: $(IDRIS) --build prelude.ipkg install: $(IDRIS) --install prelude.ipkg -clean: .PHONY +clean: $(IDRIS) --clean prelude.ipkg rebuild: clean build -linecount: .PHONY +linecount: find . -name '*.idr' | xargs wc -l -.PHONY: +.PHONY: build install clean rebuild linecount diff --git a/libs/prelude/Prelude.idr b/libs/prelude/Prelude.idr --- a/libs/prelude/Prelude.idr +++ b/libs/prelude/Prelude.idr @@ -275,11 +275,11 @@ instance Applicative (Vect k) where pure = replicate _ - fs <$> vs = zipWith ($) fs vs + fs <$> vs = zipWith apply fs vs instance Applicative Stream where pure = repeat - (<$>) = zipWith ($) + (<$>) = zipWith apply ---- Alternative instances @@ -334,7 +334,7 @@ traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |] ---- some mathematical operations ----- XXX this should probably go some place else, +---- XXX this should probably go some place else, pow : (Num a) => a -> Nat -> a pow x Z = 1 pow x (S n) = x * (pow x n) @@ -376,7 +376,7 @@ enumFromThen n inc = n :: enumFromThen (inc + n) inc enumFromTo n m = if n <= m then go (natRange (S (cast {to = Nat} (m - n)))) - else [] + else [] where go : List Nat -> List Integer go [] = [] go (x :: xs) = n + cast x :: go xs @@ -392,7 +392,7 @@ toNat n = cast n fromNat n = cast n enumFromThen n inc = n :: enumFromThen (inc + n) inc - enumFromTo n m = if n <= m + enumFromTo n m = if n <= m then go (natRange (S (cast {to = Nat} (m - n)))) else [] where go : List Nat -> List Int @@ -410,7 +410,7 @@ = enumFromThenTo start (next - start) end syntax "[" [start] "..]" - = enumFrom start 1 + = enumFrom start syntax "[" [start] "," [next] "..]" = enumFromThen start (next - start) @@ -532,12 +532,16 @@ partial nullPtr : Ptr -> IO Bool nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p - return (ok /= 0); + return (ok /= 0) partial nullStr : String -> IO Bool nullStr p = do ok <- mkForeign (FFun "isNull" [FString] FInt) p - return (ok /= 0); + return (ok /= 0) + +eqPtr : Ptr -> Ptr -> IO Bool +eqPtr x y = do eq <- mkForeign (FFun "idris_eqPtr" [FPtr, FPtr] FInt) x y + return (eq /= 0) partial validFile : File -> IO Bool diff --git a/libs/prelude/Prelude/Basics.idr b/libs/prelude/Prelude/Basics.idr --- a/libs/prelude/Prelude/Basics.idr +++ b/libs/prelude/Prelude/Basics.idr @@ -13,7 +13,7 @@ -- | Constant function. const : a -> b -> a -const x _ = x +const x = \v => x -- | Return the first element of a pair. fst : (s, t) -> s @@ -33,11 +33,9 @@ flip : (a -> b -> c) -> b -> a -> c flip f x y = f y x -infixr 1 $ - -- | Function application. -($) : (a -> b) -> a -> b -f $ a = f a +apply : (a -> b) -> a -> b +apply f a = f a cong : {f : t -> u} -> (a = b) -> f a = f b cong refl = refl diff --git a/libs/prelude/Prelude/Bool.idr b/libs/prelude/Prelude/Bool.idr --- a/libs/prelude/Prelude/Bool.idr +++ b/libs/prelude/Prelude/Bool.idr @@ -13,7 +13,6 @@ -- Syntaxtic sugar for boolean elimination. syntax if [test] then [t] else [e] = boolElim test t e -syntax [test] "?" [t] ":" [e] = if test then t else e -- Boolean Operator Precedence infixl 4 &&, || diff --git a/libs/prelude/Prelude/Either.idr b/libs/prelude/Prelude/Either.idr --- a/libs/prelude/Prelude/Either.idr +++ b/libs/prelude/Prelude/Either.idr @@ -29,9 +29,9 @@ choose True = Left oh choose False = Right oh -either : Either a b -> (a -> c) -> (b -> c) -> c -either (Left x) l r = l x -either (Right x) l r = r x +either : (a -> c) -> (b -> c) -> Either a b -> c +either l r (Left x) = l x +either l r (Right x) = r x lefts : List (Either a b) -> List a lefts [] = [] @@ -61,6 +61,17 @@ maybeToEither : e -> Maybe a -> Either e a maybeToEither def (Just j) = Right j maybeToEither def Nothing = Left def + + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +instance (Eq a, Eq b) => Eq (Either a b) where + (==) (Left x) (Left y) = x == y + (==) (Right x) (Right y) = x == y + (==) _ _ = False + -------------------------------------------------------------------------------- diff --git a/libs/prelude/Prelude/Fin.idr b/libs/prelude/Prelude/Fin.idr --- a/libs/prelude/Prelude/Fin.idr +++ b/libs/prelude/Prelude/Fin.idr @@ -38,6 +38,10 @@ weaken fZ = fZ weaken (fS k) = fS (weaken k) +weakenN : (n : Nat) -> Fin m -> Fin (m + n) +weakenN n fZ = fZ +weakenN n (fS f) = fS (weakenN n f) + strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n) strengthen {n = S k} fZ = Right fZ strengthen {n = S k} (fS i) with (strengthen i) @@ -45,6 +49,10 @@ strengthen (fS k) | Right x = Right (fS x) strengthen f = Left f +shift : (m : Nat) -> Fin n -> Fin (m + n) +shift Z f = f +shift {n=n} (S m) f = fS {k = (m + n)} (shift m f) + last : Fin (S n) last {n=Z} = fZ last {n=S _} = fS last @@ -69,7 +77,7 @@ ItIsJust : IsJust {a} (Just x) fromInteger : (x : Integer) -> - {default (ItIsJust _ _) + {default ItIsJust prf : (IsJust (integerToFin x n))} -> Fin n fromInteger {n} x {prf} with (integerToFin x n) fromInteger {n} x {prf = ItIsJust} | Just y = y diff --git a/libs/prelude/Prelude/List.idr b/libs/prelude/Prelude/List.idr --- a/libs/prelude/Prelude/List.idr +++ b/libs/prelude/Prelude/List.idr @@ -382,13 +382,12 @@ break : (a -> Bool) -> List a -> (List a, List a) break p = span (not . p) -%assert_total split : (a -> Bool) -> List a -> List (List a) split p [] = [] split p xs = case break p xs of (chunk, []) => [chunk] - (chunk, (c :: rest)) => chunk :: split p rest + (chunk, (c :: rest)) => chunk :: split p (assert_smaller xs rest) partition : (a -> Bool) -> List a -> (List a, List a) partition p [] = ([], []) @@ -432,26 +431,23 @@ Nil => True (y::ys) => x <= y && sorted (y::ys) -%assert_total -- can't work this out, because in the case which is lifted out - -- y::ys and x::xs are bigger than the inputs... mergeBy : (a -> a -> Ordering) -> List a -> List a -> List a mergeBy order [] right = right mergeBy order left [] = left mergeBy order (x::xs) (y::ys) = - case order x y of - LT => x :: mergeBy order xs (y::ys) - _ => y :: mergeBy order (x::xs) ys + if order x y == LT + then x :: mergeBy order xs (y::ys) + else y :: mergeBy order (x::xs) ys merge : Ord a => List a -> List a -> List a merge = mergeBy compare -%assert_total sort : Ord a => List a -> List a sort [] = [] sort [x] = [x] -sort xs = - let (x, y) = split xs in - merge (sort x) (sort y) -- not structurally smaller, hence assert +sort xs = let (x, y) = split xs in + merge (sort (assert_smaller xs x)) + (sort (assert_smaller xs y)) -- not structurally smaller, hence assert where splitRec : List a -> List a -> (List a -> List a) -> (List a, List a) splitRec (_::_::xs) (y::ys) zs = splitRec xs ys (zs . ((::) y)) @@ -463,10 +459,6 @@ -------------------------------------------------------------------------------- -- Conversions -------------------------------------------------------------------------------- - -maybeToList : Maybe a -> List a -maybeToList Nothing = [] -maybeToList (Just j) = [j] listToMaybe : List a -> Maybe a listToMaybe [] = Nothing diff --git a/libs/prelude/Prelude/Nat.idr b/libs/prelude/Prelude/Nat.idr --- a/libs/prelude/Prelude/Nat.idr +++ b/libs/prelude/Prelude/Nat.idr @@ -41,12 +41,11 @@ mult Z right = Z mult (S left) right = plus right $ mult left right -%assert_total fromIntegerNat : Integer -> Nat fromIntegerNat 0 = Z fromIntegerNat n = if (n > 0) then - S (fromIntegerNat (n - 1)) + S (fromIntegerNat (assert_smaller n (n - 1))) else Z @@ -223,7 +222,6 @@ total fact : Nat -> Nat fact Z = S Z -fact (S Z) = S Z fact (S n) = (S n) * fact n -------------------------------------------------------------------------------- @@ -260,19 +258,17 @@ div = divNat mod = modNat -%assert_total log2 : Nat -> Nat log2 Z = Z log2 (S Z) = Z -log2 n = S (log2 (n `divNat` 2)) +log2 n = S (log2 (assert_smaller n (n `divNat` 2))) -------------------------------------------------------------------------------- -- GCD and LCM -------------------------------------------------------------------------------- -%assert_total gcd : Nat -> Nat -> Nat gcd a Z = a -gcd a b = gcd b (a `modNat` b) +gcd a b = assert_total (gcd b (a `modNat` b)) total lcm : Nat -> Nat -> Nat lcm _ Z = Z diff --git a/libs/prelude/Prelude/Strings.idr b/libs/prelude/Prelude/Strings.idr --- a/libs/prelude/Prelude/Strings.idr +++ b/libs/prelude/Prelude/Strings.idr @@ -43,31 +43,28 @@ StrNil : StrM "" StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs) -%assert_total strHead' : (x : String) -> so (not (x == "")) -> Char -strHead' x p = prim__strHead x +strHead' x p = assert_total $ prim__strHead x -%assert_total strTail' : (x : String) -> so (not (x == "")) -> String -strTail' x p = prim__strTail x +strTail' x p = assert_total $ prim__strTail x -- we need the 'believe_me' because the operations are primitives - -%assert_total strM : (x : String) -> StrM x strM x with (choose (not (x == ""))) - strM x | (Left p) = really_believe_me $ StrCons (strHead' x p) (strTail' x p) + strM x | (Left p) = really_believe_me $ + StrCons (assert_total (strHead' x p)) + (assert_total (strTail' x p)) strM x | (Right p) = really_believe_me StrNil -- annoyingly, we need these assert_totals because StrCons doesn't have -- a recursive argument, therefore the termination checker doesn't believe -- the string is guaranteed smaller. It makes a good point. -%assert_total unpack : String -> List Char unpack s with (strM s) unpack "" | StrNil = [] - unpack (strCons x xs) | (StrCons x xs) = x :: unpack xs + unpack (strCons x xs) | (StrCons x xs) = x :: assert_total (unpack xs) pack : (Foldable t) => t Char -> String pack = foldr strCons "" @@ -90,12 +87,11 @@ instance Monoid String where neutral = "" -%assert_total span : (Char -> Bool) -> String -> (String, String) span p xs with (strM xs) span p "" | StrNil = ("", "") span p (strCons x xs) | (StrCons _ _) with (p x) - | True with (span p xs) + | True with (assert_total (span p xs)) | (ys, zs) = (strCons x ys, zs) | False = ("", strCons x xs) @@ -105,32 +101,29 @@ split : (Char -> Bool) -> String -> List String split p xs = map pack (split p (unpack xs)) -%assert_total ltrim : String -> String ltrim xs with (strM xs) ltrim "" | StrNil = "" ltrim (strCons x xs) | StrCons _ _ - = if (isSpace x) then (ltrim xs) else (strCons x xs) + = if (isSpace x) then assert_total (ltrim xs) else (strCons x xs) trim : String -> String trim xs = ltrim (reverse (ltrim (reverse xs))) -%assert_total words' : List Char -> List (List Char) words' s = case dropWhile isSpace s of [] => [] s' => let (w, s'') = break isSpace s' - in w :: words' s'' + in w :: words' (assert_smaller s s'') words : String -> List String words s = map pack $ words' $ unpack s -%assert_total lines' : List Char -> List (List Char) lines' s = case dropWhile isNL s of [] => [] s' => let (w, s'') = break isNL s' - in w :: lines' s'' + in w :: lines' (assert_smaller s s'') lines : String -> List String lines s = map pack $ lines' $ unpack s @@ -140,10 +133,9 @@ foldr1 f [x] = x foldr1 f (x::xs) = f x (foldr1 f xs) -%assert_total -- due to foldr1, but used safely unwords' : List (List Char) -> List Char unwords' [] = [] -unwords' ws = (foldr1 addSpace ws) +unwords' ws = assert_total (foldr1 addSpace ws) where addSpace : List Char -> List Char -> List Char addSpace w s = w ++ (' ' :: s) diff --git a/libs/prelude/Prelude/Vect.idr b/libs/prelude/Prelude/Vect.idr --- a/libs/prelude/Prelude/Vect.idr +++ b/libs/prelude/Prelude/Vect.idr @@ -99,6 +99,32 @@ unzip [] = ([], []) unzip ((l, r)::xs) with (unzip xs) | (lefts, rights) = (l::lefts, r::rights) + +-------------------------------------------------------------------------------- +-- Equality +-------------------------------------------------------------------------------- + +instance (Eq a) => Eq (Vect n a) where + (==) [] [] = True + (==) (x::xs) (y::ys) = + if x == y then + xs == ys + else + False + + +-------------------------------------------------------------------------------- +-- Order +-------------------------------------------------------------------------------- + +instance Ord a => Ord (Vect n a) where + compare [] [] = EQ + compare (x::xs) (y::ys) = + if x /= y then + compare x y + else + compare xs ys + -------------------------------------------------------------------------------- -- Maps diff --git a/llvm/Makefile b/llvm/Makefile --- a/llvm/Makefile +++ b/llvm/Makefile @@ -14,11 +14,11 @@ .c.o: $(CC) -c $(CFLAGS) $< -o $@ -install: $(LIB) .PHONY +install: $(LIB) mkdir -p $(TARGET) install $(LIB) $(TARGET) -clean: .PHONY +clean: rm -f $(OBJECTS) $(LIB) -.PHONY: +.PHONY: build install clean diff --git a/main/Main.hs b/main/Main.hs new file mode 100644 --- /dev/null +++ b/main/Main.hs @@ -0,0 +1,140 @@ +module Main where + +import System.Console.Haskeline +import System.IO +import System.Environment +import System.Exit +import System.FilePath ((), addTrailingPathSeparator) + +import Data.Maybe +import Data.Version +import Control.Monad.Trans.Error ( ErrorT(..) ) +import Control.Monad.Trans.State.Strict ( execStateT, get, put ) +import Control.Monad ( when ) + +import Idris.Core.TT +import Idris.Core.Typecheck +import Idris.Core.Evaluate +import Idris.Core.Constraints + +import Idris.AbsSyntax +import Idris.Parser +import Idris.REPL +import Idris.ElabDecls +import Idris.Primitives +import Idris.Imports +import Idris.Error + +import IRTS.System ( getLibFlags, getIdrisLibDir, getIncFlags ) + +import Util.DynamicLinker + +import Pkg.Package + +import Paths_idris + +-- Main program reads command line options, parses the main program, and gets +-- on with the REPL. + +main = do xs <- getArgs + let opts = parseArgs xs + result <- runErrorT $ execStateT (runIdris opts) idrisInit + case result of + Left err -> putStrLn $ "Uncaught error: " ++ show err + Right _ -> return () + +runIdris :: [Opt] -> Idris () +runIdris [Client c] = do setVerbose False + setQuiet True + runIO $ runClient c +runIdris opts = do + when (Ver `elem` opts) $ runIO showver + when (Usage `elem` opts) $ runIO usage + when (ShowIncs `elem` opts) $ runIO showIncs + when (ShowLibs `elem` opts) $ runIO showLibs + when (ShowLibdir `elem` opts) $ runIO showLibdir + case opt getPkgCheck opts of + [] -> return () + fs -> do runIO $ mapM_ (checkPkg (WarnOnly `elem` opts) True) fs + runIO $ exitWith ExitSuccess + case opt getPkgClean opts of + [] -> return () + fs -> do runIO $ mapM_ cleanPkg fs + runIO $ exitWith ExitSuccess + case opt getPkg opts of + [] -> case opt getPkgREPL opts of + [] -> idrisMain opts + [f] -> replPkg f + _ -> ifail "Too many packages" + fs -> runIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs + +usage = do putStrLn usagemsg + exitWith ExitSuccess + +showver = do putStrLn $ "Idris version " ++ ver + exitWith ExitSuccess + +showLibs = do libFlags <- getLibFlags + putStrLn libFlags + exitWith ExitSuccess + +showLibdir = do dir <- getIdrisLibDir + putStrLn dir + exitWith ExitSuccess + +showIncs = do incFlags <- getIncFlags + putStrLn incFlags + exitWith ExitSuccess + +usagemsghdr = "Idris version " ++ ver ++ ", (C) The Idris Community 2014" + +usagemsg = usagemsghdr ++ "\n" ++ + map (\x -> '-') usagemsghdr ++ "\n" ++ + "idris [OPTIONS] [FILE]\n\n" ++ + "Common flags:\n" ++ + "\t --install=IPKG Install package\n" ++ + "\t --clean=IPKG Clean package\n" ++ + "\t --build=IPKG Build package\n" ++ + "\t --exec=EXPR Execute as idris\n" ++ + "\t --libdir Display library directory\n" ++ + "\t --link Display link directory\n" ++ + "\t --include Display the includes directory\n" ++ + "\t --nobanner Suppress the banner\n" ++ + "\t --color, --colour Force coloured output\n" ++ + "\t --nocolor, --nocolour Disable coloured output\n" ++ + "\t --errorcontent Undocumented\n" ++ + "\t --nocoverage Undocumented\n" ++ + "\t -o --output=FILE Specify output file\n" ++ + "\t --check Undocumented\n" ++ + "\t --total Require functions to be total by default\n" ++ + "\t --partial Undocumented\n" ++ + "\t --warnpartial Warn about undeclared partial functions.\n" ++ + "\t --warn Undocumented\n" ++ + "\t --typecase Undocumented\n" ++ + "\t --typeintype Undocumented\n" ++ + "\t --nobasepkgs Undocumented\n" ++ + "\t --noprelude Undocumented\n" ++ + "\t --nobuiltins Undocumented\n" ++ + "\t -O --level=LEVEL Undocumented\n" ++ + "\t -i --idrispath=DIR Add directory to the list of import paths\n" ++ + "\t --package=ITEM Undocumented\n" ++ + "\t --ibcsubdir=FILE Write IBC files into sub directory\n" ++ + "\t --codegen=TARGET Select code generator: C, Java, bytecode,\n" ++ + "\t javascript, node, or llvm\n" ++ + "\t --mvn Create a maven project (for Java codegen)\n" ++ + "\t --cpu=CPU Select tartget CPU e.g. corei7 or cortex-m3\n" ++ + "\t (for LLVM codegen)\n" ++ + "\t --target=TRIPLE Select target triple (for llvm codegen)\n" ++ + "\t -S --codegenonly Do no further compilation of code generator output\n" ++ + "\t -c --compileonly Compile to object files rather than an executable\n" ++ + "\t -X --extension=ITEM Undocumented\n" ++ + "\t --dumpdefuns Undocumented\n" ++ + "\t --dumpcases Undocumented\n" ++ + "\t --log=LEVEL --loglevel Debugging log level\n" ++ + "\t --ideslave Undocumented\n" ++ + "\t --client Undocumented\n" ++ + "\t -h --help Display help message\n" ++ + "\t -v --version Print version information\n" ++ + "\t -V --verbose Loud verbosity\n" ++ + "\t -q --quiet Quiet verbosity\n" + diff --git a/rts/Makefile b/rts/Makefile --- a/rts/Makefile +++ b/rts/Makefile @@ -15,13 +15,13 @@ ar r $(LIBTARGET) $(OBJS) ranlib $(LIBTARGET) -install : .PHONY +install : mkdir -p $(TARGET) install $(LIBTARGET) $(HDRS) $(TARGET) -clean : .PHONY +clean : rm -f $(OBJS) $(LIBTARGET) $(DYLIBTARGET) idris_rts.o: idris_rts.h -.PHONY: +.PHONY: build install clean diff --git a/rts/idris_gc.c b/rts/idris_gc.c --- a/rts/idris_gc.c +++ b/rts/idris_gc.c @@ -27,6 +27,9 @@ case STROFFSET: cl = MKSTROFFc(vm, x->info.str_offset); break; + case BUFFER: + cl = MKBUFFERc(vm, x->info.buf); + break; case BIGINT: cl = MKBIGMc(vm, x->info.ptr); break; diff --git a/rts/idris_rts.c b/rts/idris_rts.c --- a/rts/idris_rts.c +++ b/rts/idris_rts.c @@ -475,6 +475,240 @@ return cl; } +VAL MKBUFFERc(VM* vm, Buffer* buf) { + Closure* cl = allocate(vm, sizeof(Closure) + sizeof *buf + buf->cap, 1); + SETTY(cl, BUFFER); + cl->info.buf = (Buffer*)((void*)cl + sizeof(Closure)); + memmove(cl->info.buf, buf, sizeof *buf + buf->fill); + return cl; +} + +static VAL internal_allocate(VM *vm, size_t hint) { + size_t size = hint + sizeof(Closure) + sizeof(Buffer); + + // Round up to a power of 2 + --size; + size_t i; + for (i = 0; i <= sizeof size; ++i) + size |= size >> (1 << i); + ++size; + + Closure* cl = allocate(vm, size, 0); + SETTY(cl, BUFFER); + cl->info.buf = (Buffer*)((void*)cl + sizeof(Closure)); + cl->info.buf->cap = size - (sizeof(Closure) + sizeof(Buffer)); + return cl; +} + +// Following functions cast uint64_t to size_t, which may narrow! +VAL idris_allocate(VM* vm, VAL hint) { + Closure* cl = internal_allocate(vm, hint->info.bits64); + cl->info.buf->fill = 0; + return cl; +} + +static void internal_memset(void *dest, const void *src, size_t size, size_t num) { + while (num--) { + memmove(dest, src, size); + dest += size; + } +} + +static VAL internal_prepare_append(VM* vm, VAL buf, size_t bufLen, size_t appLen) { + size_t totalLen = bufLen + appLen; + Closure* cl; + if (bufLen != buf->info.buf->fill || + totalLen > buf->info.buf->cap) { + // We're not at the fill or are over cap, so need a new buffer + cl = internal_allocate(vm, totalLen); + memmove(cl->info.buf->store, + buf->info.buf->store, + bufLen); + cl->info.buf->fill = totalLen; + } else { + // Hooray, can just bump the fill + cl = buf; + cl->info.buf->fill += appLen; + } + return cl; +} + +VAL idris_appendBuffer(VM* vm, VAL fst, VAL fstLen, VAL cnt, VAL sndLen, VAL sndOff, VAL snd) { + size_t firstLength = fstLen->info.bits64; + size_t secondLength = sndLen->info.bits64; + size_t count = cnt->info.bits64; + size_t offset = sndOff->info.bits64; + Closure* cl = internal_prepare_append(vm, fst, firstLength, count * secondLength); + internal_memset(cl->info.buf->store + firstLength, snd->info.buf->store + offset, secondLength, count); + return cl; +} + +// Special cased because we can use memset +VAL idris_appendB8Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val) { + size_t bufLen = len->info.bits64; + size_t count = cnt->info.bits64; + Closure* cl = internal_prepare_append(vm, buf, bufLen, count); + memset(cl->info.buf->store + bufLen, val->info.bits8, count); + return cl; +} + +static VAL internal_append_bits(VM* vm, VAL buf, VAL bufLen, VAL cnt, const void* val, size_t val_len) { + size_t len = bufLen->info.bits64; + size_t count = cnt->info.bits64; + Closure* cl = internal_prepare_append(vm, buf, len, count * val_len); + internal_memset(cl->info.buf->store + len, val, val_len, count); + return cl; +} + +VAL idris_appendB16Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val) { + return internal_append_bits(vm, buf, len, cnt, &val->info.bits16, sizeof val->info.bits16); +} + +VAL idris_appendB16LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val) { + // On gcc 4.8 -O3 compiling for x86_64, using leVal like this is + // optimized away. Presumably the same holds for other sizes and + // conversly on BE systems + unsigned char leVal[sizeof val] = { val->info.bits16 + , (val->info.bits16 >> 8) + }; + return internal_append_bits(vm, buf, len, cnt, leVal, sizeof leVal); +} + +VAL idris_appendB16BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val) { + unsigned char beVal[sizeof val] = { (val->info.bits16 >> 8) + , val->info.bits16 + }; + return internal_append_bits(vm, buf, len, cnt, beVal, sizeof beVal); +} + +VAL idris_appendB32Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val) { + return internal_append_bits(vm, buf, len, cnt, &val->info.bits32, sizeof val->info.bits32); +} + +VAL idris_appendB32LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val) { + unsigned char leVal[sizeof val] = { val->info.bits32 + , (val->info.bits32 >> 8) + , (val->info.bits32 >> 16) + , (val->info.bits32 >> 24) + }; + return internal_append_bits(vm, buf, len, cnt, leVal, sizeof leVal); +} + +VAL idris_appendB32BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val) { + unsigned char beVal[sizeof val] = { (val->info.bits32 >> 24) + , (val->info.bits32 >> 16) + , (val->info.bits32 >> 8) + , val->info.bits32 + }; + return internal_append_bits(vm, buf, len, cnt, beVal, sizeof beVal); +} + +VAL idris_appendB64Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val) { + return internal_append_bits(vm, buf, len, cnt, &val->info.bits64, sizeof val->info.bits64); +} + +VAL idris_appendB64LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val) { + unsigned char leVal[sizeof val] = { val->info.bits64 + , (val->info.bits64 >> 8) + , (val->info.bits64 >> 16) + , (val->info.bits64 >> 24) + , (val->info.bits64 >> 32) + , (val->info.bits64 >> 40) + , (val->info.bits64 >> 48) + , (val->info.bits64 >> 56) + }; + return internal_append_bits(vm, buf, len, cnt, leVal, sizeof leVal); +} + +VAL idris_appendB64BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val) { + unsigned char beVal[sizeof val] = { (val->info.bits64 >> 56) + , (val->info.bits64 >> 48) + , (val->info.bits64 >> 40) + , (val->info.bits64 >> 32) + , (val->info.bits64 >> 24) + , (val->info.bits64 >> 16) + , (val->info.bits64 >> 8) + , val->info.bits64 + }; + return internal_append_bits(vm, buf, len, cnt, beVal, sizeof beVal); +} + +VAL idris_peekB8Native(VM* vm, VAL buf, VAL off) { + size_t offset = off->info.bits64; + uint8_t *val = buf->info.buf->store + offset; + return MKB8(vm, *val); +} + +VAL idris_peekB16Native(VM* vm, VAL buf, VAL off) { + size_t offset = off->info.bits64; + uint16_t *val = (uint16_t *) (buf->info.buf->store + offset); + return MKB16(vm, *val); +} + +VAL idris_peekB16LE(VM* vm, VAL buf, VAL off) { + size_t offset = off->info.bits64; + return MKB16(vm, ((uint16_t) buf->info.buf->store[offset]) + + (((uint16_t) buf->info.buf->store[offset + 1]) << 8)); +} + +VAL idris_peekB16BE(VM* vm, VAL buf, VAL off) { + size_t offset = off->info.bits64; + return MKB16(vm, ((uint16_t) buf->info.buf->store[offset + 1]) + + (((uint16_t) buf->info.buf->store[offset]) << 8)); +} + +VAL idris_peekB32Native(VM* vm, VAL buf, VAL off) { + size_t offset = off->info.bits64; + uint32_t *val = (uint32_t *) (buf->info.buf->store + offset); + return MKB32(vm, *val); +} + +VAL idris_peekB32LE(VM* vm, VAL buf, VAL off) { + size_t offset = off->info.bits64; + return MKB32(vm, ((uint32_t) buf->info.buf->store[offset]) + + (((uint32_t) buf->info.buf->store[offset + 1]) << 8) + + (((uint32_t) buf->info.buf->store[offset + 2]) << 16) + + (((uint32_t) buf->info.buf->store[offset + 3]) << 24)); +} + +VAL idris_peekB32BE(VM* vm, VAL buf, VAL off) { + size_t offset = off->info.bits64; + return MKB32(vm, ((uint32_t) buf->info.buf->store[offset + 3]) + + (((uint32_t) buf->info.buf->store[offset + 2]) << 8) + + (((uint32_t) buf->info.buf->store[offset + 1]) << 16) + + (((uint32_t) buf->info.buf->store[offset]) << 24)); +} + +VAL idris_peekB64Native(VM* vm, VAL buf, VAL off) { + size_t offset = off->info.bits64; + uint64_t *val = (uint64_t *) (buf->info.buf->store + offset); + return MKB64(vm, *val); +} + +VAL idris_peekB64LE(VM* vm, VAL buf, VAL off) { + size_t offset = off->info.bits64; + return MKB64(vm, ((uint64_t) buf->info.buf->store[offset]) + + (((uint64_t) buf->info.buf->store[offset + 1]) << 8) + + (((uint64_t) buf->info.buf->store[offset + 2]) << 16) + + (((uint64_t) buf->info.buf->store[offset + 3]) << 24) + + (((uint64_t) buf->info.buf->store[offset + 4]) << 32) + + (((uint64_t) buf->info.buf->store[offset + 5]) << 40) + + (((uint64_t) buf->info.buf->store[offset + 6]) << 48) + + (((uint64_t) buf->info.buf->store[offset + 7]) << 56)); +} + +VAL idris_peekB64BE(VM* vm, VAL buf, VAL off) { + size_t offset = off->info.bits64; + return MKB64(vm, ((uint64_t) buf->info.buf->store[offset + 7]) + + (((uint64_t) buf->info.buf->store[offset + 6]) << 8) + + (((uint64_t) buf->info.buf->store[offset + 5]) << 16) + + (((uint64_t) buf->info.buf->store[offset + 4]) << 24) + + (((uint64_t) buf->info.buf->store[offset + 3]) << 32) + + (((uint64_t) buf->info.buf->store[offset + 2]) << 40) + + (((uint64_t) buf->info.buf->store[offset + 1]) << 48) + + (((uint64_t) buf->info.buf->store[offset]) << 56)); +} + typedef struct { VM* vm; // thread's VM VM* callvm; // calling thread's VM @@ -552,6 +786,9 @@ case STRING: cl = MKSTRc(vm, x->info.str); break; + case BUFFER: + cl = MKBUFFERc(vm, x->info.buf); + break; case BIGINT: cl = MKBIGMc(vm, x->info.ptr); break; @@ -602,7 +839,7 @@ pthread_mutex_lock(&(dest->inbox_lock)); *(dest->inbox_write) = dmsg; - + dest->inbox_write++; if (dest->inbox_write >= dest->inbox_end) { dest->inbox_write = dest->inbox; diff --git a/rts/idris_rts.h b/rts/idris_rts.h --- a/rts/idris_rts.h +++ b/rts/idris_rts.h @@ -16,7 +16,8 @@ typedef enum { CON, INT, BIGINT, FLOAT, STRING, STROFFSET, - BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD + BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD, + BUFFER } ClosureType; typedef struct Closure *VAL; @@ -31,6 +32,15 @@ int offset; } StrOffset; +typedef struct { + // If we ever have multithreaded access to the same heap, + // fill is mutable so needs synchronization! + size_t fill; + size_t cap; + unsigned char store[]; +} Buffer; + + typedef struct Closure { // Use top 16 bits of ty for saying which heap value is in // Bottom 16 bits for closure type @@ -46,6 +56,7 @@ uint16_t bits16; uint32_t bits32; uint64_t bits64; + Buffer* buf; } info; } Closure; @@ -162,6 +173,7 @@ VAL MKSTROFFc(VM* vm, StrOffset* off); VAL MKSTRc(VM* vm, char* str); VAL MKPTRc(VM* vm, void* ptr); +VAL MKBUFFERc(VM* vm, Buffer* buf); char* GETSTROFF(VAL stroff); @@ -233,6 +245,30 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs); VAL idris_strIndex(VM* vm, VAL str, VAL i); VAL idris_strRev(VM* vm, VAL str); + +// Buffer primitives +VAL idris_allocate(VM* vm, VAL hint); +VAL idris_appendBuffer(VM* vm, VAL fst, VAL fstLen, VAL cnt, VAL sndLen, VAL sndOff, VAL snd); +VAL idris_appendB8Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); +VAL idris_appendB16Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); +VAL idris_appendB16LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); +VAL idris_appendB16BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); +VAL idris_appendB32Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); +VAL idris_appendB32LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); +VAL idris_appendB32BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); +VAL idris_appendB64Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); +VAL idris_appendB64LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); +VAL idris_appendB64BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); +VAL idris_peekB8Native(VM* vm, VAL buf, VAL off); +VAL idris_peekB16Native(VM* vm, VAL buf, VAL off); +VAL idris_peekB16LE(VM* vm, VAL buf, VAL off); +VAL idris_peekB16BE(VM* vm, VAL buf, VAL off); +VAL idris_peekB32Native(VM* vm, VAL buf, VAL off); +VAL idris_peekB32LE(VM* vm, VAL buf, VAL off); +VAL idris_peekB32BE(VM* vm, VAL buf, VAL off); +VAL idris_peekB64Native(VM* vm, VAL buf, VAL off); +VAL idris_peekB64LE(VM* vm, VAL buf, VAL off); +VAL idris_peekB64BE(VM* vm, VAL buf, VAL off); // Command line args diff --git a/rts/idris_stdfgn.c b/rts/idris_stdfgn.c --- a/rts/idris_stdfgn.c +++ b/rts/idris_stdfgn.c @@ -36,6 +36,10 @@ return ptr==NULL; } +int idris_eqPtr(void* x, void* y) { + return x==y; +} + void* idris_stdin() { return (void*)stdin; } diff --git a/rts/idris_stdfgn.h b/rts/idris_stdfgn.h --- a/rts/idris_stdfgn.h +++ b/rts/idris_stdfgn.h @@ -12,6 +12,7 @@ int fileError(void* h); void fputStr(void*h, char* str); +int idris_eqPtr(void* x, void* y); int isNull(void* ptr); void* idris_stdin(); diff --git a/src/Core/CaseTree.hs b/src/Core/CaseTree.hs deleted file mode 100644 --- a/src/Core/CaseTree.hs +++ /dev/null @@ -1,566 +0,0 @@ -{-# LANGUAGE PatternGuards, DeriveFunctor, TypeSynonymInstances #-} - -module Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..), - Phase(..), CaseTree, - simpleCase, small, namesUsed, findCalls, findUsedArgs) where - -import Core.TT - -import Control.Monad.State -import Data.Maybe -import Data.List hiding (partition) -import Debug.Trace - -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 - | STerm !t - | UnmatchedCase String -- ^ error message - | ImpossibleCase -- ^ already checked to be impossible - deriving (Eq, Ord, Functor) -{-! -deriving instance Binary SC -!-} - -type SC = SC' Term - -data CaseAlt' t = ConCase Name Int [Name] !(SC' t) - | FnCase Name [Name] !(SC' t) -- ^ reflection function - | ConstCase Const !(SC' t) - | SucCase Name !(SC' t) - | DefaultCase !(SC' t) - deriving (Show, Eq, Ord, Functor) -{-! -deriving instance Binary CaseAlt -!-} - -type CaseAlt = CaseAlt' Term - -instance Show t => Show (SC' t) where - show sc = show' 1 sc - where - show' i (Case n alts) = "case " ++ show n ++ " of\n" ++ indent i ++ - showSep ("\n" ++ indent i) (map (showA i) alts) - show' i (ProjCase tm alts) = "case " ++ show tm ++ " of " ++ - showSep ("\n" ++ indent i) (map (showA i) alts) - show' i (STerm tm) = show tm - show' i (UnmatchedCase str) = "error " ++ show str - show' i ImpossibleCase = "impossible" - - indent i = concat $ take i (repeat " ") - - showA i (ConCase n t args sc) - = show n ++ "(" ++ showSep (", ") (map show args) ++ ") => " - ++ show' (i+1) sc - showA i (FnCase n args sc) - = "FN " ++ show n ++ "(" ++ showSep (", ") (map show args) ++ ") => " - ++ show' (i+1) sc - showA i (ConstCase t sc) - = show t ++ " => " ++ show' (i+1) sc - showA i (SucCase n sc) - = show n ++ "+1 => " ++ show' (i+1) sc - showA i (DefaultCase sc) - = "_ => " ++ show' (i+1) sc - - -type CaseTree = SC -type Clause = ([Pat], (Term, Term)) -type CS = ([Term], Int) - -instance TermSize SC where - termsize n (Case n' as) = termsize n as - termsize n (ProjCase n' as) = termsize n as - termsize n (STerm t) = termsize n t - termsize n _ = 1 - -instance TermSize CaseAlt where - termsize n (ConCase _ _ _ s) = termsize n s - termsize n (FnCase _ _ s) = termsize n s - termsize n (ConstCase _ s) = termsize n s - termsize n (SucCase _ s) = termsize n s - termsize n (DefaultCase s) = termsize n s - --- simple terms can be inlined trivially - good for primitives in particular --- To avoid duplicating work, don't inline something which uses one --- of its arguments in more than one place - -small :: Name -> [Name] -> SC -> Bool -small n args t = let as = findAllUsedArgs t args in - length as == length (nub as) && - termsize n t < 10 - -namesUsed :: SC -> [Name] -namesUsed sc = nub $ nu' [] sc where - nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n] - nu' ps (ProjCase t alts) = nub $ (nut ps t ++ - (concatMap (nua ps) alts)) - nu' ps (STerm t) = nub $ nut ps t - nu' ps _ = [] - - nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc) \\ args - nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc) \\ args - nua ps (ConstCase _ sc) = nu' ps sc - nua ps (SucCase _ sc) = nu' ps sc - nua ps (DefaultCase sc) = nu' ps sc - - nut ps (P _ n _) | n `elem` ps = [] - | otherwise = [n] - nut ps (App f a) = nut ps f ++ nut ps a - nut ps (Proj t _) = nut ps t - nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc - nut ps (Bind n b sc) = nut (n:ps) sc - nut ps _ = [] - --- Return all called functions, and which arguments are used in each argument position --- for the call, in order to help reduce compilation time, and trace all unused --- arguments - -findCalls :: SC -> [Name] -> [(Name, [[Name]])] -findCalls sc topargs = nub $ nu' topargs sc where - nu' ps (Case n alts) = nub (concatMap (nua (n : ps)) alts) - nu' ps (ProjCase t alts) = nub (nut ps t ++ concatMap (nua ps) alts) - nu' ps (STerm t) = nub $ nut ps t - nu' ps _ = [] - - nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc) - nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc) - nua ps (ConstCase _ sc) = nu' ps sc - nua ps (SucCase _ sc) = nu' ps sc - nua ps (DefaultCase sc) = nu' ps sc - - nut ps (P Ref n _) | n `elem` ps = [] - | otherwise = [(n, [])] -- tmp - nut ps fn@(App f a) - | (P Ref n _, args) <- unApply fn - = if n `elem` ps then nut ps f ++ nut ps a - else [(n, map argNames args)] ++ concatMap (nut ps) args - | (P (TCon _ _) n _, _) <- unApply fn = [] - | otherwise = nut ps f ++ nut ps a - nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc - nut ps (Proj t _) = nut ps t - nut ps (Bind n b sc) = nut (n:ps) sc - nut ps _ = [] - - argNames tm = let ns = directUse tm in - filter (\x -> x `elem` ns) topargs - --- Find names which are used directly (i.e. not in a function call) in a term - -directUse :: Eq n => TT n -> [n] -directUse (P _ n _) = [n] -directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n]) - ++ directUse t -directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n]) -directUse fn@(App f a) - | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them - | otherwise = nub $ directUse f ++ directUse a -directUse (Proj x i) = nub $ directUse x -directUse _ = [] - --- Find all directly used arguments (i.e. used but not in function calls) - -findUsedArgs :: SC -> [Name] -> [Name] -findUsedArgs sc topargs = nub (findAllUsedArgs sc topargs) - -findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where - nu' (Case n alts) = n : concatMap nua alts - nu' (ProjCase t alts) = directUse t ++ concatMap nua alts - nu' (STerm t) = directUse t - nu' _ = [] - - nua (ConCase n i args sc) = nu' sc - nua (FnCase n args sc) = nu' sc - nua (ConstCase _ sc) = nu' sc - nua (SucCase _ sc) = nu' sc - nua (DefaultCase sc) = nu' sc - -data Phase = CompileTime | RunTime - deriving (Show, Eq) - --- Generate a simple case tree --- Work Right to Left - -simpleCase :: Bool -> Bool -> Bool -> - Phase -> FC -> [([Name], Term, Term)] -> - TC CaseDef -simpleCase tc cover reflect 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") [] - sc' tc cover phase fc cs - = let proj = phase == RunTime - pats = map (\ (avs, l, r) -> - (avs, toPats reflect tc l, (l, r))) cs - chkPats = mapM chkAccessible pats in - case chkPats of - OK pats -> - let numargs = length (fst (head pats)) - ns = take numargs args - (ns', ps') = order ns pats - (tree, st) = runState - (match ns' ps' (defaultCase cover)) ([], numargs) - t = CaseDef ns (prune proj (depatt ns' tree)) (fst st) in - if proj then return (stripLambdas t) else return t - Error err -> Error (At fc err) - where args = map (\i -> MN i "e") [0..] - defaultCase True = STerm Erased - defaultCase False = UnmatchedCase "Error" - - chkAccessible (avs, l, c) - | phase == RunTime || reflect = return (l, c) - | otherwise = do mapM_ (acc l) avs - return (l, c) - - acc [] n = Error (Inaccessible n) - acc (PV x : xs) n | x == n = OK () - acc (PCon _ _ ps : xs) n = acc (ps ++ xs) n - acc (PSuc p : xs) n = acc (p : xs) n - acc (_ : xs) n = acc xs n - -data Pat = PCon Name Int [Pat] - | PConst Const - | PV Name - | PSuc Pat -- special case for n+1 on Integer - | PReflected Name [Pat] - | PAny - deriving Show - --- If there are repeated variables, take the *last* one (could be name shadowing --- in a where clause, so take the most recent). - -toPats :: Bool -> Bool -> Term -> [Pat] -toPats reflect tc f = reverse (toPat reflect tc (getArgs f)) where - getArgs (App f a) = a : getArgs f - getArgs _ = [] - -toPat :: Bool -> Bool -> [Term] -> [Pat] -toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) [] - where - toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args - return $ PCon n t args' - -- n + 1 - toPat' (P _ (UN "prim__addBigInt") _) - [p, Constant (BI 1)] - = do p' <- toPat' p [] - return $ PSuc p' - -- Typecase - toPat' (P (TCon t a) n _) args | tc - = do args' <- mapM (\x -> toPat' x []) args - return $ PCon n t args' - toPat' (Constant (AType (ATInt ITNative))) [] - | tc = return $ PCon (UN "Int") 1 [] - toPat' (Constant (AType ATFloat)) [] | tc = return $ PCon (UN "Float") 2 [] - toPat' (Constant (AType (ATInt ITChar))) [] | tc = return $ PCon (UN "Char") 3 [] - toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 [] - toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 [] - toPat' (Constant (AType (ATInt ITBig))) [] - | tc = return $ PCon (UN "Integer") 6 [] - toPat' (Constant (AType (ATInt (ITFixed n)))) [] - | tc = return $ PCon (UN (fixedN n)) (7 + fromEnum n) [] -- 7-10 inclusive - toPat' (P Bound n _) [] = do ns <- get - if n `elem` ns - then return PAny - else do put (n : ns) - return (PV n) - toPat' (App f a) args = toPat' f (a : args) - toPat' (Constant x) [] = return $ PConst x - toPat' (Bind n (Pi t) sc) [] | reflect && noOccurrence n sc - = do t' <- toPat' t [] - sc' <- toPat' sc [] - return $ PReflected (UN "->") (t':sc':[]) - toPat' (P _ n _) args | reflect - = do args' <- mapM (\x -> toPat' x []) args - return $ PReflected n args' - toPat' t _ = return PAny - - fixedN IT8 = "Bits8" - fixedN IT16 = "Bits16" - fixedN IT32 = "Bits32" - fixedN IT64 = "Bits64" - - -data Partition = Cons [Clause] - | Vars [Clause] - deriving Show - -isVarPat (PV _ : ps , _) = True -isVarPat (PAny : ps , _) = True -isVarPat _ = False - -isConPat (PCon _ _ _ : ps, _) = True -isConPat (PReflected _ _ : ps, _) = True -isConPat (PSuc _ : ps, _) = True -isConPat (PConst _ : ps, _) = True -isConPat _ = False - -partition :: [Clause] -> [Partition] -partition [] = [] -partition ms@(m : _) - | isVarPat m = let (vars, rest) = span isVarPat ms in - Vars vars : partition rest - | isConPat m = let (cons, rest) = span isConPat ms in - Cons cons : partition rest -partition xs = error $ "Partition " ++ show xs - --- reorder the patterns so that the one with most distinct names --- comes next. Take rightmost first, otherwise (i.e. pick value rather --- than dependency) - -order :: [Name] -> [Clause] -> ([Name], [Clause]) -order [] cs = ([], cs) -order ns [] = (ns, []) -order ns cs = let patnames = transpose (map (zip ns) (map fst cs)) - pats' = transpose (sortBy moreDistinct (reverse patnames)) in - (getNOrder pats', zipWith rebuild pats' cs) - where - getNOrder [] = error $ "Failed order on " ++ show (ns, cs) - getNOrder (c : _) = map fst c - - rebuild patnames clause = (map snd patnames, snd clause) - - moreDistinct xs ys = compare (numNames [] (map snd ys)) - (numNames [] (map snd xs)) - - numNames xs (PCon n _ _ : ps) - | not (Left n `elem` xs) = numNames (Left n : xs) ps - numNames xs (PConst c : ps) - | not (Right c `elem` xs) = numNames (Right c : xs) ps - numNames xs (_ : ps) = numNames xs ps - numNames xs [] = length xs - -match :: [Name] -> [Clause] -> SC -- error case - -> State CS SC -match [] (([], ret) : xs) err - = do (ts, v) <- get - put (ts ++ (map (fst.snd) xs), v) - case snd ret of - Impossible -> return ImpossibleCase - tm -> return $ STerm tm -- run out of arguments -match vs cs err = do let ps = partition cs - mixture vs ps err - -mixture :: [Name] -> [Partition] -> SC -> State CS SC -mixture vs [] err = return err -mixture vs (Cons ms : ps) err = do fallthrough <- mixture vs ps err - conRule vs ms fallthrough -mixture vs (Vars ms : ps) err = do fallthrough <- mixture vs ps err - varRule vs ms fallthrough - -data ConType = CName Name Int -- named constructor - | CFn Name -- reflected function name - | CSuc -- n+1 - | CConst Const -- constant, not implemented yet - deriving (Show, Eq) - -data Group = ConGroup ConType -- Constructor - [([Pat], Clause)] -- arguments and rest of alternative - deriving Show - -conRule :: [Name] -> [Clause] -> SC -> State CS SC -conRule (v:vs) cs err = do groups <- groupCons cs - caseGroups (v:vs) groups err - -caseGroups :: [Name] -> [Group] -> SC -> State CS SC -caseGroups (v:vs) gs err = do g <- altGroups gs - return $ Case v (sort g) - where - altGroups [] = return [DefaultCase err] - altGroups (ConGroup (CName n i) args : cs) - = do g <- altGroup n i args - rest <- altGroups cs - return (g : rest) - altGroups (ConGroup (CFn n) args : cs) - = do g <- altFnGroup n args - rest <- altGroups cs - return (g : rest) - altGroups (ConGroup CSuc args : cs) - = do g <- altSucGroup args - rest <- altGroups cs - return (g : rest) - altGroups (ConGroup (CConst c) args : cs) - = do g <- altConstGroup c args - rest <- altGroups cs - return (g : rest) - - altGroup n i gs = do (newArgs, nextCs) <- argsToAlt gs - matchCs <- match (newArgs ++ vs) nextCs err - return $ ConCase n i newArgs matchCs - altFnGroup n gs = do (newArgs, nextCs) <- argsToAlt gs - matchCs <- match (newArgs ++ vs) nextCs err - return $ FnCase n newArgs matchCs - altSucGroup gs = do ([newArg], nextCs) <- argsToAlt gs - matchCs <- match (newArg:vs) nextCs err - return $ SucCase newArg matchCs - altConstGroup n gs = do (_, nextCs) <- argsToAlt gs - matchCs <- match vs nextCs err - return $ ConstCase n matchCs - -argsToAlt :: [([Pat], Clause)] -> State CS ([Name], [Clause]) -argsToAlt [] = return ([], []) -argsToAlt rs@((r, m) : rest) - = do newArgs <- getNewVars r - return (newArgs, addRs rs) - where - getNewVars [] = return [] - getNewVars ((PV n) : ns) = do v <- getVar "e" - nsv <- getNewVars ns - return (v : nsv) - 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 [] = [] - addRs ((r, (ps, res)) : rs) = ((r++ps, res) : addRs rs) - - uniq i (UN n) = MN i n - uniq i n = n - -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 - where - gc acc [] = return acc - gc acc ((p : ps, res) : cs) = - do acc' <- addGroup p ps res acc - gc acc' cs - addGroup p ps res acc = case p of - PCon con i args -> return $ addg (CName con i) args (ps, res) acc - PConst cval -> return $ addConG cval (ps, res) acc - PSuc n -> return $ addg CSuc [n] (ps, res) acc - PReflected fn args -> return $ addg (CFn fn) args (ps, res) acc - pat -> fail $ show pat ++ " is not a constructor or constant (can't happen)" - - addg c conargs res [] - = [ConGroup c [(conargs, res)]] - addg c conargs res (g@(ConGroup c' cs):gs) - | c == c' = ConGroup c (cs ++ [(conargs, res)]) : gs - | otherwise = g : addg c conargs res gs - - addConG con res [] = [ConGroup (CConst con) [([], res)]] - addConG con res (g@(ConGroup (CConst n) cs) : gs) - | con == n = ConGroup (CConst n) (cs ++ [([], res)]) : gs --- | otherwise = g : addConG con res gs - addConG con res (g : gs) = g : addConG con res gs - -varRule :: [Name] -> [Clause] -> SC -> State CS SC -varRule (v : vs) alts err = - 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 (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 - dp ms (STerm tm) = STerm (applyMaps ms tm) - dp ms (Case x alts) = Case x (map (dpa ms x) alts) - dp ms sc = sc - - dpa ms x (ConCase n i args sc) - = ConCase n i args (dp ((x, (n, args)) : ms) sc) - dpa ms x (FnCase n args sc) - = FnCase n args (dp ((x, (n, args)) : ms) sc) - dpa ms x (ConstCase c sc) = ConstCase c (dp ms sc) - dpa ms x (SucCase n sc) = SucCase n (dp ms sc) - dpa ms x (DefaultCase sc) = DefaultCase (dp ms sc) - - applyMaps ms f@(App _ _) - | (P nt cn pty, args) <- unApply f - = let args' = map (applyMaps ms) args in - applyMap ms nt cn pty args' - where - applyMap [] nt cn pty args' = mkApp (P nt cn pty) args' - applyMap ((x, (n, args)) : ms) nt cn pty args' - | 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 _ _ = False - - applyMaps ms (App f a) = App (applyMaps ms f) (applyMaps ms a) - applyMaps ms t = t - --- FIXME: Do this for SucCase too -prune :: Bool -- ^ Convert single branches to projections (only useful at runtime) - -> SC -> SC -prune proj (Case n alts) - = let alts' = filter notErased (map pruneAlt alts) in - case alts' of - [] -> ImpossibleCase - as@[ConCase cn i args sc] -> if proj then mkProj n 0 args sc - else Case n as - as@[SucCase cn sc] -> if proj then mkProj n (-1) [cn] sc - else Case n as - as@[ConstCase _ sc] -> prune proj sc - -- Bit of a hack here! The default case will always be 0, make sure - -- it gets caught first. - [s@(SucCase _ _), DefaultCase dc] - -> Case n [ConstCase (BI 0) dc, s] - as -> Case n as - where pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc) - pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc) - pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc) - pruneAlt (SucCase n sc) = SucCase n (prune proj sc) - pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc) - - notErased (DefaultCase (STerm Erased)) = False - notErased (DefaultCase ImpossibleCase) = False - notErased _ = True - - mkProj n i [] sc = prune proj sc - mkProj n i (x : xs) sc = mkProj n (i + 1) xs (projRep x n i sc) - - -- Change every 'n' in sc to 'n-1' --- mkProjS n cn sc = prune proj (fmap projn sc) where --- projn pn@(P _ n' _) --- | cn == n' = App (App (P Ref (UN "prim__subBigInt") Erased) --- (P Bound n Erased)) (Constant (BI 1)) --- projn t = t - - projRep :: Name -> Name -> Int -> SC -> SC - projRep arg n i (Case x alts) - | x == arg = ProjCase (Proj (P Bound n Erased) i) - (map (projRepAlt arg n i) alts) - | otherwise = Case x (map (projRepAlt arg n i) alts) - projRep arg n i (ProjCase t alts) - = ProjCase (projRepTm arg n i t) (map (projRepAlt arg n i) alts) - projRep arg n i (STerm t) = STerm (projRepTm arg n i t) - projRep arg n i c = c -- unmatched - - projRepAlt arg n i (ConCase cn t args rhs) - = ConCase cn t args (projRep arg n i rhs) - projRepAlt arg n i (FnCase cn args rhs) - = FnCase cn args (projRep arg n i rhs) - projRepAlt arg n i (ConstCase t rhs) - = ConstCase t (projRep arg n i rhs) - projRepAlt arg n i (SucCase sn rhs) - = SucCase sn (projRep arg n i rhs) - projRepAlt arg n i (DefaultCase rhs) - = DefaultCase (projRep arg n i rhs) - - projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t - -prune _ t = t - -stripLambdas :: CaseDef -> CaseDef -stripLambdas (CaseDef ns (STerm (Bind x (Lam _) sc)) tm) - = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm) -stripLambdas x = x - - - - diff --git a/src/Core/Constraints.hs b/src/Core/Constraints.hs deleted file mode 100644 --- a/src/Core/Constraints.hs +++ /dev/null @@ -1,67 +0,0 @@ --- | Check universe constraints. -module Core.Constraints(ucheck) where - -import Core.TT - -import Control.Applicative -import Control.Arrow -import Control.Monad.Error -import Control.Monad.RWS -import Control.Monad.State -import Data.List -import Data.Maybe -import qualified Data.Map as M - -import Debug.Trace - --- | Check that a list of universe constraints can be satisfied. -ucheck :: [(UConstraint, FC)] -> TC () -ucheck cs = acyclic rels (map fst (M.toList rels)) - where lhs (ULT l _) = l - lhs (ULE l _) = l - rels = mkRels cs M.empty - -type Relations = M.Map UExp [(UConstraint, FC)] - -mkRels :: [(UConstraint, FC)] -> Relations -> Relations -mkRels [] acc = acc -mkRels ((c, f) : cs) acc - | not (ignore c) - = case M.lookup (lhs c) acc of - Nothing -> mkRels cs (M.insert (lhs c) [(c,f)] acc) - Just rs -> mkRels cs (M.insert (lhs c) ((c,f):rs) acc) - | otherwise = mkRels cs acc - where lhs (ULT l _) = l - lhs (ULE l _) = l - ignore (ULE l r) = l == r - ignore _ = False - - -acyclic :: Relations -> [UExp] -> TC () -acyclic r cvs = checkCycle (fileFC "root") r [] 0 cvs - where - checkCycle :: FC -> Relations -> [(UExp, FC)] -> Int -> [UExp] -> TC () - checkCycle fc r path inc [] = return () - checkCycle fc r path inc (c : cs) - = do check fc path inc c - -- Remove c from r since we know there's no cycles now - let r' = M.insert c [] r - checkCycle fc r' path inc cs - - check fc path inc (UVar x) | x < 0 = return () - check fc path inc cv - | inc > 0 && cv `elem` map fst path - = Error $ At fc UniverseError - -- FIXME: Make informative - -- e.g. (Msg ("Cycle: " ++ show cv ++ ", " ++ show path)) - -- if we reach a cycle but we're at the same universe level, it's - -- fine, because they must all be equal, so stop. - | inc == 0 && cv `elem` map fst path - = return () - | otherwise = case M.lookup cv r of - Nothing -> return () - Just cs -> mapM_ (next ((cv, fc):path) inc) cs - - next path inc (ULT l r, fc) = check fc path (inc + 1) r - next path inc (ULE l r, fc) = check fc path inc r - diff --git a/src/Core/Elaborate.hs b/src/Core/Elaborate.hs deleted file mode 100644 --- a/src/Core/Elaborate.hs +++ /dev/null @@ -1,661 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-} - -{- A high level language of tactic composition, for building - elaborators from a high level language into the core theory. - - This is our interface to proof construction, rather than - ProofState, because this gives us a language to build derived - tactics out of the primitives. --} - -module Core.Elaborate(module Core.Elaborate, - module Core.ProofState) where - -import Core.ProofState -import Core.TT -import Core.Evaluate -import Core.Typecheck -import Core.Unify - -import Control.Monad.State -import Data.Char -import Data.List -import Debug.Trace - -import Util.Pretty - --- I don't really want this here, but it's useful for the test shell -data Command = Theorem Name Raw - | Eval Raw - | Quit - | Print Name - | Tac (Elab ()) - -data ElabState aux = ES (ProofState, aux) String (Maybe (ElabState aux)) - deriving Show - -type Elab' aux a = StateT (ElabState aux) TC a -type Elab a = Elab' () a - -proof :: ElabState aux -> ProofState -proof (ES (p, _) _ _) = p - --- Insert a 'proofSearchFail' error if necessary to shortcut any further --- fruitless searching -proofFail :: Elab' aux a -> Elab' aux a -proofFail e = do s <- get - case runStateT e s of - OK (a, s') -> do put s' - return a - Error err -> lift $ Error (ProofSearchFail err) - -saveState :: Elab' aux () -saveState = do e@(ES p s _) <- get - put (ES p s (Just e)) - -loadState :: Elab' aux () -loadState = do (ES p s e) <- get - case e of - Just st -> put st - _ -> fail "Nothing to undo" - -errAt :: String -> Name -> Elab' aux a -> Elab' aux a -errAt thing n elab = do s <- get - case runStateT elab s of - OK (a, s') -> do put s' - return a - Error (At f e) -> - lift $ Error (At f (Elaborating thing n e)) - Error e -> lift $ Error (Elaborating thing n e) - -erun :: FC -> Elab' aux a -> Elab' aux a -erun f elab = do s <- get - case runStateT elab s of - OK (a, s') -> do put s' - return a - Error (ProofSearchFail (At f e)) - -> lift $ Error (ProofSearchFail (At f e)) - Error (At f e) -> lift $ Error (At f e) - Error e -> lift $ Error (At f e) - -runElab :: aux -> Elab' aux a -> ProofState -> TC (a, ElabState aux) -runElab a e ps = runStateT e (ES (ps, a) "" Nothing) - -execElab :: aux -> Elab' aux a -> ProofState -> TC (ElabState aux) -execElab a e ps = execStateT e (ES (ps, a) "" Nothing) - -initElaborator :: Name -> Context -> Type -> ProofState -initElaborator = newProof - -elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String) -elaborate ctxt n ty d elab = do let ps = initElaborator n ctxt ty - (a, ES ps' str _) <- runElab d elab ps - return (a, str) - -updateAux :: (aux -> aux) -> Elab' aux () -updateAux f = do ES (ps, a) l p <- get - put (ES (ps, f a) l p) - -getAux :: Elab' aux aux -getAux = do ES (ps, a) _ _ <- get - return a - -unifyLog :: Bool -> Elab' aux () -unifyLog log = do ES (ps, a) l p <- get - put (ES (ps { unifylog = log }, a) l p) - -processTactic' t = do ES (p, a) logs prev <- get - (p', log) <- lift $ processTactic t p - put (ES (p', a) (logs ++ log) prev) - return () - --- Some handy gadgets for pulling out bits of state - --- get the global context -get_context :: Elab' aux Context -get_context = do ES p _ _ <- get - return (context (fst p)) - --- update the context --- (should only be used for adding temporary definitions or all sorts of --- stuff could go wrong) -set_context :: Context -> Elab' aux () -set_context ctxt = do ES (p, a) logs prev <- get - put (ES (p { context = ctxt }, a) logs prev) - --- get the proof term -get_term :: Elab' aux Term -get_term = do ES p _ _ <- get - return (pterm (fst p)) - --- get the proof term -update_term :: (Term -> Term) -> Elab' aux () -update_term f = do ES (p,a) logs prev <- get - let p' = p { pterm = f (pterm p) } - put (ES (p', a) logs prev) - --- get the local context at the currently in focus hole -get_env :: Elab' aux Env -get_env = do ES p _ _ <- get - lift $ envAtFocus (fst p) - -get_holes :: Elab' aux [Name] -get_holes = do ES p _ _ <- get - return (holes (fst p)) - -get_probs :: Elab' aux Fails -get_probs = do ES p _ _ <- get - return (problems (fst p)) - --- get the current goal type -goal :: Elab' aux Type -goal = do ES p _ _ <- get - b <- lift $ goalAtFocus (fst p) - return (binderTy b) - --- Get the guess at the current hole, if there is one -get_guess :: Elab' aux Type -get_guess = do ES p _ _ <- get - b <- lift $ goalAtFocus (fst p) - case b of - Guess t v -> return v - _ -> fail "Not a guess" - --- typecheck locally -get_type :: Raw -> Elab' aux Type -get_type tm = do ctxt <- get_context - env <- get_env - (val, ty) <- lift $ check ctxt env tm - return (finalise ty) - -get_type_val :: Raw -> Elab' aux (Term, Type) -get_type_val tm = do ctxt <- get_context - env <- get_env - (val, ty) <- lift $ check ctxt env tm - return (finalise val, finalise ty) - --- get holes we've deferred for later definition -get_deferred :: Elab' aux [Name] -get_deferred = do ES p _ _ <- get - return (deferred (fst p)) - -checkInjective :: (Term, Term, Term) -> Elab' aux () -checkInjective (tm, l, r) = do ctxt <- get_context - if isInj ctxt tm then return () - else lift $ tfail (NotInjective tm l r) - where isInj ctxt (P _ n _) - | isConName n ctxt = True - isInj ctxt (App f a) = isInj ctxt f - isInj ctxt (Constant _) = True - isInj ctxt (TType _) = True - isInj ctxt (Bind _ (Pi _) sc) = True - isInj ctxt _ = False - --- get instance argument names -get_instances :: Elab' aux [Name] -get_instances = do ES p _ _ <- get - return (instances (fst p)) - --- given a desired hole name, return a unique hole name -unique_hole = unique_hole' False - -unique_hole' :: Bool -> Name -> Elab' aux Name -unique_hole' reusable n - = do ES p _ _ <- get - let bs = bound_in (pterm (fst p)) ++ - bound_in (ptype (fst p)) - n' <- uniqueNameCtxt (context (fst p)) n (holes (fst p) - ++ bs ++ dontunify (fst p) ++ usedns (fst p)) - ES (p, a) s u <- get - -- Hmm: Do we need this level of uniqueness? - let p' = p -- if reusable then p else p { usedns = n' : usedns p } - put (ES (p', a) s u) - return n' - where - bound_in (Bind n b sc) = n : bi b ++ bound_in sc - where - bi (Let t v) = bound_in t ++ bound_in v - bi (Guess t v) = bound_in t ++ bound_in v - bi b = bound_in (binderTy b) - bound_in (App f a) = bound_in f ++ bound_in a - bound_in _ = [] - -uniqueNameCtxt :: Context -> Name -> [Name] -> Elab' aux Name -uniqueNameCtxt ctxt n hs - | n `elem` hs = uniqueNameCtxt ctxt (nextName n) hs - | [_] <- lookupTy n ctxt = uniqueNameCtxt ctxt (nextName n) hs - | otherwise = return n - -elog :: String -> Elab' aux () -elog str = do ES p logs prev <- get - put (ES p (logs ++ str ++ "\n") prev) - -getLog :: Elab' aux String -getLog = do ES p logs _ <- get - return logs - --- The primitives, from ProofState - -attack :: Elab' aux () -attack = processTactic' Attack - -claim :: Name -> Raw -> Elab' aux () -claim n t = processTactic' (Claim n t) - -exact :: Raw -> Elab' aux () -exact t = processTactic' (Exact t) - -fill :: Raw -> Elab' aux () -fill t = processTactic' (Fill t) - -match_fill :: Raw -> Elab' aux () -match_fill t = processTactic' (MatchFill t) - -prep_fill :: Name -> [Name] -> Elab' aux () -prep_fill n ns = processTactic' (PrepFill n ns) - -complete_fill :: Elab' aux () -complete_fill = processTactic' CompleteFill - -solve :: Elab' aux () -solve = processTactic' Solve - -start_unify :: Name -> Elab' aux () -start_unify n = processTactic' (StartUnify n) - -end_unify :: Elab' aux () -end_unify = processTactic' EndUnify - -regret :: Elab' aux () -regret = processTactic' Regret - -compute :: Elab' aux () -compute = processTactic' Compute - -computeLet :: Name -> Elab' aux () -computeLet n = processTactic' (ComputeLet n) - -simplify :: Elab' aux () -simplify = processTactic' Simplify - -hnf_compute :: Elab' aux () -hnf_compute = processTactic' HNF_Compute - -eval_in :: Raw -> Elab' aux () -eval_in t = processTactic' (EvalIn t) - -check_in :: Raw -> Elab' aux () -check_in t = processTactic' (CheckIn t) - -intro :: Maybe Name -> Elab' aux () -intro n = processTactic' (Intro n) - -introTy :: Raw -> Maybe Name -> Elab' aux () -introTy ty n = processTactic' (IntroTy ty n) - -forall :: Name -> Raw -> Elab' aux () -forall n t = processTactic' (Forall n t) - -letbind :: Name -> Raw -> Raw -> Elab' aux () -letbind n t v = processTactic' (LetBind n t v) - -expandLet :: Name -> Term -> Elab' aux () -expandLet n v = processTactic' (ExpandLet n v) - -rewrite :: Raw -> Elab' aux () -rewrite tm = processTactic' (Rewrite tm) - -equiv :: Raw -> Elab' aux () -equiv tm = processTactic' (Equiv tm) - -patvar :: Name -> Elab' aux () -patvar n = do env <- get_env - if (n `elem` map fst env) then do apply (Var n) []; solve - else do n' <- case n of - UN _ -> return n - MN _ _ -> unique_hole n - NS _ _ -> return n - processTactic' (PatVar n') - -patbind :: Name -> Elab' aux () -patbind n = processTactic' (PatBind n) - -focus :: Name -> Elab' aux () -focus n = processTactic' (Focus n) - -movelast :: Name -> Elab' aux () -movelast n = processTactic' (MoveLast n) - -matchProblems :: Elab' aux () -matchProblems = processTactic' MatchProblems - -unifyProblems :: Elab' aux () -unifyProblems = processTactic' UnifyProblems - -defer :: Name -> Elab' aux () -defer n = do n' <- unique_hole n - processTactic' (Defer n') - -deferType :: Name -> Raw -> [Name] -> Elab' aux () -deferType n ty ns = processTactic' (DeferType n ty ns) - -instanceArg :: Name -> Elab' aux () -instanceArg n = processTactic' (Instance n) - -setinj :: Name -> Elab' aux () -setinj n = processTactic' (SetInjective n) - -proofstate :: Elab' aux () -proofstate = processTactic' ProofState - -reorder_claims :: Name -> Elab' aux () -reorder_claims n = processTactic' (Reorder n) - -qed :: Elab' aux Term -qed = do processTactic' QED - ES p _ _ <- get - return (pterm (fst p)) - -undo :: Elab' aux () -undo = processTactic' Undo - -prepare_apply :: Raw -> [Bool] -> Elab' aux [Name] -prepare_apply fn imps = - do ty <- get_type fn - ctxt <- get_context - env <- get_env - -- let claims = getArgs ty imps - -- claims <- mkClaims (normalise ctxt env ty) imps [] - claims <- mkClaims (finalise ty) imps [] (map fst env) - ES (p, a) s prev <- get - -- reverse the claims we made so that args go left to right - let n = length (filter not imps) - let (h : hs) = holes p - put (ES (p { holes = h : (reverse (take n hs) ++ drop n hs) }, a) s prev) --- case claims of --- [] -> return () --- (h : _) -> reorder_claims h - return claims - where - mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs = - do let t = rebind hs t_in - n <- unique_hole (mkMN n') --- when (null claims) (start_unify n) - let sc' = instantiate (P Bound n t) sc --- trace ("CLAIMING " ++ show (n, t) ++ " with " ++ show hs) $ - claim n (forget t) - when i (movelast n) - mkClaims sc' is (n : claims) hs - mkClaims t [] claims _ = return (reverse claims) - mkClaims _ _ _ _ - | Var n <- fn - = do ctxt <- get_context - case lookupTy n ctxt of - [] -> lift $ tfail $ NoSuchVariable n - _ -> lift $ tfail $ TooManyArguments n - | otherwise = fail $ "Too many arguments for " ++ show fn - - doClaim ((i, _), n, t) = do claim n t - when i (movelast n) - - mkMN n@(MN _ _) = n - mkMN n@(UN x) = MN 1000 x - mkMN n@(SN s) = MN 1000 (show s) - mkMN (NS n xs) = NS (mkMN n) xs - - rebind hs (Bind n t sc) - | n `elem` hs = let n' = uniqueName n hs in - Bind n' (fmap (rebind hs) t) (rebind (n':hs) sc) - | otherwise = Bind n (fmap (rebind hs) t) (rebind (n:hs) sc) - rebind hs (App f a) = App (rebind hs f) (rebind hs a) - rebind hs t = t - -apply, match_apply :: Raw -> [(Bool, Int)] -> Elab' aux [Name] -apply = apply' fill -match_apply = apply' match_fill - -apply' :: (Raw -> Elab' aux ()) -> Raw -> [(Bool, Int)] -> Elab' aux [Name] -apply' fillt fn imps = - do args <- prepare_apply fn (map fst imps) - env <- get_env - g <- goal - fillt (raw_apply fn (map Var args)) - -- _Don't_ solve the arguments we're specifying by hand. - -- (remove from unified list before calling end_unify) - -- HMMM: Actually, if we get it wrong, the typechecker will complain! - -- so do nothing - ptm <- get_term - hs <- get_holes - ES (p, a) s prev <- get - let dont = nub $ head hs : dontunify p ++ - if null imps then [] -- do all we can - 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 - let unify = -- trace ("Not done " ++ show hs) $ - 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) $ - end_unify - ptm <- get_term - return (map (updateUnify unify) args) - where updateUnify hs n = case lookup n hs of - Just (P _ t _) -> t - _ -> n - -apply2 :: Raw -> [Maybe (Elab' aux ())] -> Elab' aux () -apply2 fn elabs = - do args <- prepare_apply fn (map isJust elabs) - fill (raw_apply fn (map Var args)) - elabArgs args elabs - ES (p, a) s prev <- get - let (n, hs) = unified p - end_unify - solve - where elabArgs [] [] = return () - elabArgs (n:ns) (Just e:es) = do focus n; e - elabArgs ns es - elabArgs (n:ns) (_:es) = elabArgs ns es - - isJust (Just _) = False - isJust _ = True - -apply_elab :: Name -> [Maybe (Int, Elab' aux ())] -> Elab' aux () -apply_elab n args = - do ty <- get_type (Var n) - ctxt <- get_context - env <- get_env - claims <- doClaims (hnf ctxt env ty) args [] - prep_fill n (map fst claims) - let eclaims = sortBy (\ (_, x) (_,y) -> priOrder x y) claims - elabClaims [] False claims - complete_fill - end_unify - where - priOrder Nothing Nothing = EQ - priOrder Nothing _ = LT - priOrder _ Nothing = GT - priOrder (Just (x, _)) (Just (y, _)) = compare x y - - doClaims (Bind n' (Pi t) sc) (i : is) claims = - do n <- unique_hole (mkMN n') - when (null claims) (start_unify n) - let sc' = instantiate (P Bound n t) sc - claim n (forget t) - case i of - Nothing -> return () - Just _ -> -- don't solve by unification as there is an explicit value - do ES (p, a) s prev <- get - put (ES (p { dontunify = n : dontunify p }, a) s prev) - doClaims sc' is ((n, i) : claims) - doClaims t [] claims = return (reverse claims) - doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n - - elabClaims failed r [] - | null failed = return () - | otherwise = if r then elabClaims [] False failed - else return () - elabClaims failed r ((n, Nothing) : xs) = elabClaims failed r xs - elabClaims failed r (e@(n, Just (_, elaboration)) : xs) - | r = try (do ES p _ _ <- get - focus n; elaboration; elabClaims failed r xs) - (elabClaims (e : failed) r xs) - | otherwise = do ES p _ _ <- get - focus n; elaboration; elabClaims failed r xs - - mkMN n@(MN _ _) = n - 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 :: Name -> Elab' aux () -checkPiGoal n - = do g <- goal - case g of - Bind _ (Pi _) _ -> return () - _ -> do a <- unique_hole (MN 0 "pargTy") - b <- unique_hole (MN 0 "pretTy") - f <- unique_hole (MN 0 "pf") - claim a RType - claim b RType - claim f (RBind n (Pi (Var a)) (Var b)) - movelast a - movelast b - fill (Var f) - solve - focus f - -simple_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux () -simple_app fun arg appstr = - 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 - claim b RType - claim f (RBind (MN 0 "aX") (Pi (Var a)) (Var b)) - tm <- get_term - start_unify s - claim s (Var a) - prep_fill f [s] - focus f; fun - focus s; arg - tm <- get_term - ps <- get_probs - complete_fill - hs <- get_holes - env <- get_env - -- We don't need a and b in the hole queue any more since they were - -- just for checking f, so discard them if they are still there. - -- If they haven't been solved, regret will fail - when (a `elem` hs) $ do focus a; regretWith (CantInferType appstr) - when (b `elem` hs) $ do focus b; regretWith (CantInferType appstr) - end_unify - where regretWith err = try regret - (lift $ tfail err) - --- Abstract over an argument of unknown type, giving a name for the hole --- which we'll fill with the argument type too. -arg :: Name -> Name -> Elab' aux () -arg n tyhole = do ty <- unique_hole tyhole - 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 - -try' :: Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a -try' t1 t2 proofSearch - = do s <- get - ps <- get_probs - 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 - Error e2 -> if score e1 >= score e2 - then lift (tfail e1) - else lift (tfail e2) - else lift (tfail e1) - where recoverableErr err@(CantUnify r _ _ _ _ _) - = -- traceWhen r (show err) $ - r || proofSearch - recoverableErr (ProofSearchFail _) = False - recoverableErr _ = True - -tryWhen :: Bool -> Elab' aux a -> Elab' aux a -> Elab' aux a -tryWhen True a b = try a b -tryWhen False a b = a - - --- Try a selection of tactics. Exactly one must work, all others must fail -tryAll :: [(Elab' aux a, String)] -> Elab' aux a -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] pmax _ [] = res - tryAll' (_:_) pmax _ [] = cantResolve - tryAll' [] pmax (f, _) [] = f - tryAll' cs pmax f (x:xs) - = do s <- get - ps <- get_probs - 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 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 pmax zok ps x s - = case runStateT x s of - OK (v, s'@(ES (p, _) _ _)) -> - 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, 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 diff --git a/src/Core/Evaluate.hs b/src/Core/Evaluate.hs deleted file mode 100644 --- a/src/Core/Evaluate.hs +++ /dev/null @@ -1,905 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, - PatternGuards #-} - -module Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll, - rt_simplify, simplify, specialise, hnf, convEq, convEq', - Def(..), CaseInfo(..), CaseDefs(..), - Accessibility(..), Totality(..), PReason(..), - Context, initContext, ctxtAlist, uconstraints, next_tvar, - addToCtxt, setAccess, setTotal, addCtxtDef, addTyDecl, - addDatatype, addCasedef, simplifyCasedef, addOperator, - lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal, - lookupTotal, lookupNameTotal, lookupTyEnv, isDConName, isTConName, isConName, isFnName, - Value(..), Quote(..), initEval) where - -import Debug.Trace -import Control.Monad.State -import qualified Data.Binary as B -import Data.Binary hiding (get, put) - -import Core.TT -import Core.CaseTree - -data EvalState = ES { limited :: [(Name, Int)], - nexthole :: Int } - deriving Show - -type Eval a = State EvalState a - -data EvalOpt = Spec - | HNF - | Simplify - | AtREPL - | RunTT - deriving (Show, Eq) - -initEval = ES [] 0 - --- VALUES (as HOAS) --------------------------------------------------------- --- | A HOAS representation of values -data Value = VP NameType Name Value - | VV Int - -- True for Bool indicates safe to reduce - | VBind Bool Name (Binder Value) (Value -> Eval Value) - -- For frozen let bindings when simplifying - | VBLet Int Name Value Value Value - | VApp Value Value - | VType UExp - | VErased - | VImpossible - | VConstant Const - | VProj Value Int --- | VLazy Env [Value] Term - | VTmp Int - -instance Show Value where - show x = show $ evalState (quote 100 x) initEval - -instance Show (a -> b) where - show x = "<>" - --- THE EVALUATOR ------------------------------------------------------------ - --- The environment is assumed to be "locally named" - i.e., not de Bruijn --- indexed. --- i.e. it's an intermediate environment that we have while type checking or --- while building a proof. - --- | Normalise fully type checked terms (so, assume all names/let bindings resolved) -normaliseC :: Context -> Env -> TT Name -> TT Name -normaliseC ctxt env t - = evalState (do val <- eval False ctxt [] env t [] - quote 0 val) initEval - -normaliseAll :: Context -> Env -> TT Name -> TT Name -normaliseAll ctxt env t - = evalState (do val <- eval False ctxt [] env t [AtREPL] - quote 0 val) initEval - -normalise :: Context -> Env -> TT Name -> TT Name -normalise = normaliseTrace False - -normaliseTrace :: Bool -> Context -> Env -> TT Name -> TT Name -normaliseTrace tr ctxt env t - = evalState (do val <- eval tr ctxt [] (map finalEntry env) (finalise t) [] - quote 0 val) initEval - -specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> TT Name -specialise ctxt env limits t - = evalState (do val <- eval False ctxt [] - (map finalEntry env) (finalise t) - [Spec] - quote 0 val) (initEval { limited = limits }) - --- | Like normalise, but we only reduce functions that are marked as okay to --- inline (and probably shouldn't reduce lets?) --- 20130908: now only used to reduce for totality checking. Inlining should --- be done elsewhere. - -simplify :: Context -> Env -> TT Name -> TT Name -simplify ctxt env t - = evalState (do val <- eval False ctxt [(UN "lazy", 0), - (UN "assert_smaller", 0), - (UN "par", 0), - (UN "prim__syntactic_eq", 0), - (UN "fork", 0)] - (map finalEntry env) (finalise t) - [Simplify] - quote 0 val) initEval - --- | Simplify for run-time (i.e. basic inlining) -rt_simplify :: Context -> Env -> TT Name -> TT Name -rt_simplify ctxt env t - = evalState (do val <- eval False ctxt [(UN "lazy", 0), - (UN "assert_smaller", 0), - (UN "par", 0), - (UN "prim__syntactic_eq", 0), - (UN "prim_fork", 0)] - (map finalEntry env) (finalise t) - [RunTT] - quote 0 val) initEval - --- | Reduce a term to head normal form -hnf :: Context -> Env -> TT Name -> TT Name -hnf ctxt env t - = evalState (do val <- eval False ctxt [] - (map finalEntry env) - (finalise t) [HNF] - quote 0 val) initEval - - --- unbindEnv env (quote 0 (eval ctxt (bindEnv env t))) - -finalEntry :: (Name, Binder (TT Name)) -> (Name, Binder (TT Name)) -finalEntry (n, b) = (n, fmap finalise b) - -bindEnv :: EnvTT n -> TT n -> TT n -bindEnv [] tm = tm -bindEnv ((n, Let t v):bs) tm = Bind n (NLet t v) (bindEnv bs tm) -bindEnv ((n, b):bs) tm = Bind n b (bindEnv bs tm) - -unbindEnv :: EnvTT n -> TT n -> TT n -unbindEnv [] tm = tm -unbindEnv (_:bs) (Bind n b sc) = unbindEnv bs sc - -usable :: Bool -- specialising - -> Name -> [(Name, Int)] -> Eval (Bool, [(Name, Int)]) --- usable _ _ ns@((MN 0 "STOP", _) : _) = return (False, ns) -usable False n [] = return (True, []) -usable True n ns - = do ES ls num <- get - case lookup n ls of - Just 0 -> return (False, ns) - Just i -> return (True, ns) - _ -> return (False, ns) -usable False n ns - = case lookup n ns of - Just 0 -> return (False, ns) - Just i -> return $ (True, (n, abs (i-1)) : filter (\ (n', _) -> n/=n') ns) - _ -> return $ (True, (n, 100) : filter (\ (n', _) -> n/=n') ns) - - -deduct :: Name -> Eval () -deduct n = do ES ls num <- get - case lookup n ls of - Just i -> do put $ ES ((n, (i-1)) : - filter (\ (n', _) -> n/=n') ls) num - _ -> return () - --- | Evaluate in a context of locally named things (i.e. not de Bruijn indexed, --- such as we might have during construction of a proof) - --- The (Name, Int) pair in the arguments is the maximum depth of unfolding of --- a name. The corresponding pair in the state is the maximum number of --- unfoldings overall. - -eval :: Bool -> Context -> [(Name, Int)] -> Env -> TT Name -> - [EvalOpt] -> Eval Value -eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where - spec = Spec `elem` opts - simpl = Simplify `elem` opts - runtime = RunTT `elem` opts - atRepl = AtREPL `elem` opts - hnf = HNF `elem` opts - - -- returns 'True' if the function should block - -- normal evaluation should return false - blockSimplify (CaseInfo inl dict) n stk - | RunTT `elem` opts - = not (inl || dict) || elem n stk - | Simplify `elem` opts - = (not (inl || dict) || elem n stk) - || (n == UN "prim__syntactic_eq") - | otherwise = False - - getCases cd | simpl = cases_totcheck cd - | runtime = cases_runtime cd - | otherwise = cases_compiletime cd - - ev ntimes stk top env (P _ n ty) - | Just (Let t v) <- lookup n genv = ev ntimes stk top env v - ev ntimes_in stk top env (P Ref n ty) - | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty) - | otherwise - = do (u, ntimes) <- usable spec n ntimes_in - if u then - do let val = lookupDefAcc n (spec || atRepl) ctxt - case val of - [(Function _ tm, Public)] -> - ev ntimes (n:stk) True env tm - [(Function _ tm, Hidden)] -> - ev ntimes (n:stk) True env tm - [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty - return $ VP nt n vty - [(CaseOp ci _ _ _ cd, acc)] - | (acc /= Frozen) && - null (fst (cases_totcheck cd)) -> -- unoptimised version - let (ns, tree) = getCases cd in - if blockSimplify ci n stk - then liftM (VP Ref n) (ev ntimes stk top env ty) - else -- traceWhen runtime (show (n, ns, tree)) $ - do c <- evCase ntimes n (n:stk) top env ns [] tree - case c of - (Nothing, _) -> liftM (VP Ref n) (ev ntimes stk top env ty) - (Just v, _) -> return v - _ -> liftM (VP Ref n) (ev ntimes stk top env ty) - else liftM (VP Ref n) (ev ntimes stk top env ty) - ev ntimes stk top env (P nt n ty) - = liftM (VP nt n) (ev ntimes stk top env ty) - ev ntimes stk top env (V i) - | i < length env && i >= 0 = return $ env !! i - | otherwise = return $ VV i - ev ntimes stk top env (Bind n (Let t v) sc) - = do v' <- ev ntimes stk top env v --(finalise v) - sc' <- ev ntimes stk top (v' : env) sc - wknV (-1) sc' --- | otherwise --- = do t' <- ev ntimes stk top env t --- v' <- ev ntimes stk top env v --(finalise v) --- -- use Tmp as a placeholder, then make it a variable reference --- -- again when evaluation finished --- hs <- get --- let vd = nexthole hs --- put (hs { nexthole = vd + 1 }) --- sc' <- ev ntimes stk top (VP Bound (MN vd "vlet") VErased : env) sc --- return $ VBLet vd n t' v' sc' - ev ntimes stk top env (Bind n (NLet t v) sc) - = do t' <- ev ntimes stk top env (finalise t) - v' <- ev ntimes stk top env (finalise v) - sc' <- ev ntimes stk top (v' : env) sc - return $ VBind True n (Let t' v') (\x -> return sc') - ev ntimes stk top env (Bind n b sc) - = do b' <- vbind env b - return $ VBind True -- (vinstances 0 sc < 2) - n b' (\x -> ev ntimes stk False (x:env) sc) - where vbind env t --- | simpl --- = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes) --- stk top env (finalise tm)) t --- | otherwise - = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t - ev ntimes stk top env (App f a) - = do f' <- ev ntimes stk False env f - a' <- ev ntimes stk False env a - evApply ntimes stk top env [a'] f' - ev ntimes stk top env (Proj t i) - = do -- evaluate dictionaries if it means the projection works - t' <- ev ntimes stk top env t --- tfull' <- reapply ntimes stk top env t' [] - return (doProj t' (getValArgs t')) - where doProj t' (VP (DCon _ _) _ _, args) | i < length args = args!!i - doProj t' _ = VProj t' i - - ev ntimes stk top env (Constant c) = return $ VConstant c - ev ntimes stk top env Erased = return VErased - ev ntimes stk top env Impossible = return VImpossible - ev ntimes stk top env (TType i) = return $ VType i - - evApply ntimes stk top env args (VApp f a) - = evApply ntimes stk top env (a:args) f - evApply ntimes stk top env args f - = apply ntimes stk top env f args - - reapply ntimes stk top env f@(VP Ref n ty) args - = let val = lookupDefAcc n (spec || atRepl) ctxt in - case val of - [(CaseOp ci _ _ _ cd, acc)] -> - let (ns, tree) = getCases cd in - do c <- evCase ntimes n (n:stk) top env ns args tree - case c of - (Nothing, _) -> return $ unload env (VP Ref n ty) args - (Just v, rest) -> evApply ntimes stk top env rest v - _ -> case args of - (a : as) -> return $ unload env f (a : as) - [] -> return f - reapply ntimes stk top env (VApp f a) args - = reapply ntimes stk top env f (a : args) - reapply ntimes stk top env v args = return v - - apply ntimes stk top env (VBind True n (Lam t) sc) (a:as) - = do a' <- sc a - app <- apply ntimes stk top env a' as - wknV (-1) app - apply ntimes_in stk top env f@(VP Ref n ty) args - | not top && hnf = case args of - [] -> return f - _ -> return $ unload env f args - | otherwise - = do (u, ntimes) <- usable spec n ntimes_in - if u then - do let val = lookupDefAcc n (spec || atRepl) ctxt - case val of - [(CaseOp ci _ _ _ cd, acc)] - | acc /= Frozen -> -- unoptimised version - let (ns, tree) = getCases cd in - if blockSimplify ci n stk - then return $ unload env (VP Ref n ty) args - else -- traceWhen runtime (show (n, ns, tree)) $ - do c <- evCase ntimes n (n:stk) top env ns args tree - case c of - (Nothing, _) -> return $ unload env (VP Ref n ty) args - (Just v, rest) -> evApply ntimes stk top env rest v - [(Operator _ i op, _)] -> - if (i <= length args) - then case op (take i args) of - Nothing -> return $ unload env (VP Ref n ty) args - Just v -> evApply ntimes stk top env (drop i args) v - else return $ unload env (VP Ref n ty) args - _ -> case args of - [] -> return f - _ -> return $ unload env f args - else case args of - (a : as) -> return $ unload env f (a:as) - [] -> return f - apply ntimes stk top env f (a:as) = return $ unload env f (a:as) - apply ntimes stk top env f [] = return f - --- specApply stk env f@(VP Ref n ty) args --- = 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 --- else return $ unload env f args --- _ -> return $ unload env f args --- specApply stk env f args = return $ unload env f args - - unload :: [Value] -> Value -> [Value] -> Value - unload env f [] = f - unload env f (a:as) = unload env (VApp f a) as - - evCase ntimes n stk top env ns args tree - | length ns <= length args - = do let args' = take (length ns) args - let rest = drop (length ns) args - when spec $ deduct n -- successful, so deduct usages - t <- evTree ntimes stk top env (zip ns args') tree --- (zipWith (\n , t) -> (n, t)) ns args') tree - return (t, rest) - | otherwise = return (Nothing, args) - - evTree :: [(Name, Int)] -> [Name] -> Bool -> - [Value] -> [(Name, Value)] -> SC -> Eval (Maybe Value) - evTree ntimes stk top env amap (UnmatchedCase str) = return Nothing - evTree ntimes stk top env amap (STerm tm) - = do let etm = pToVs (map fst amap) tm - etm' <- ev ntimes stk (not (conHeaded tm)) - (map snd amap ++ env) etm - return $ Just etm' - evTree ntimes stk top env amap (ProjCase t alts) - = do t' <- ev ntimes stk top env t - doCase ntimes stk top env amap t' alts - evTree ntimes stk top env amap (Case n alts) - = case lookup n amap of - Just v -> doCase ntimes stk top env amap v alts - _ -> return Nothing - evTree ntimes stk top env amap ImpossibleCase = return Nothing - - doCase ntimes stk top env amap v alts = - do c <- chooseAlt env v (getValArgs v) alts amap - case c of - Just (altmap, sc) -> evTree ntimes stk top env altmap sc - _ -> do c' <- chooseAlt' ntimes stk env v (getValArgs v) alts amap - case c' of - Just (altmap, sc) -> evTree ntimes stk top env altmap sc - _ -> return Nothing - - conHeaded tm@(App _ _) - | (P (DCon _ _) _ _, args) <- unApply tm = True - conHeaded t = False - - chooseAlt' ntimes stk env _ (f, args) alts amap - = do f' <- apply ntimes stk True env f args - chooseAlt env f' (getValArgs f') - alts amap - - chooseAlt :: [Value] -> Value -> (Value, [Value]) -> [CaseAlt] -> - [(Name, Value)] -> - Eval (Maybe ([(Name, Value)], SC)) - chooseAlt env _ (VP (DCon i a) _ _, args) alts amap - | Just (ns, sc) <- findTag i alts = return $ Just (updateAmap (zip ns args) amap, sc) - | Just v <- findDefault alts = return $ Just (amap, v) - chooseAlt env _ (VP (TCon i a) _ _, args) alts amap - | Just (ns, sc) <- findTag i alts - = return $ Just (updateAmap (zip ns args) amap, sc) - | Just v <- findDefault alts = return $ Just (amap, v) - chooseAlt env _ (VConstant c, []) alts amap - | Just v <- findConst c alts = return $ Just (amap, v) - | Just (n', sub, sc) <- findSuc c alts - = return $ Just (updateAmap [(n',sub)] amap, sc) - | Just v <- findDefault alts = return $ Just (amap, v) - chooseAlt env _ (VP _ n _, args) alts amap - | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc) - chooseAlt env _ (VBind _ _ (Pi s) t, []) alts amap - | Just (ns, sc) <- findFn (UN "->") alts - = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern - return $ Just (updateAmap (zip ns [s, t']) amap, sc) - chooseAlt _ _ _ alts amap - | Just v <- findDefault alts - = if (any fnCase alts) - then return $ Just (amap, v) - else return Nothing - | otherwise = return Nothing - - fnCase (FnCase _ _ _) = True - fnCase _ = False - - -- Replace old variable names in the map with new matches - -- (This is possibly unnecessary since we make unique names and don't - -- allow repeated variables...?) - updateAmap newm amap - = newm ++ filter (\ (x, _) -> not (elem x (map fst newm))) amap - findTag i [] = Nothing - findTag i (ConCase n j ns sc : xs) | i == j = Just (ns, sc) - findTag i (_ : xs) = findTag i xs - - findFn fn [] = Nothing - findFn fn (FnCase n ns sc : xs) | fn == n = Just (ns, sc) - findFn fn (_ : xs) = findFn fn xs - - findDefault [] = Nothing - findDefault (DefaultCase sc : xs) = Just sc - findDefault (_ : xs) = findDefault xs - - findSuc c [] = Nothing - findSuc (BI val) (SucCase n sc : _) - | val /= 0 = Just (n, VConstant (BI (val - 1)), sc) - findSuc c (_ : xs) = findSuc c xs - - findConst c [] = Nothing - findConst c (ConstCase c' v : xs) | c == c' = Just v - findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v - findConst (AType ATFloat) (ConCase n 2 [] v : xs) = Just v - findConst (AType (ATInt ITChar)) (ConCase n 3 [] v : xs) = Just v - findConst StrType (ConCase n 4 [] v : xs) = Just v - findConst PtrType (ConCase n 5 [] v : xs) = Just v - findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v - findConst (AType (ATInt (ITFixed ity))) (ConCase n tag [] v : xs) - | tag == 7 + fromEnum ity = Just v - findConst (AType (ATInt (ITVec ity count))) (ConCase n tag [] v : xs) - | tag == (fromEnum ity + 1) * 1000 + count = Just v - findConst c (_ : xs) = findConst c xs - - getValArgs tm = getValArgs' tm [] - getValArgs' (VApp f a) as = getValArgs' f (a:as) - getValArgs' f as = (f, as) - --- tmpToV i vd (VLetHole j) | vd == j = return $ VV i --- tmpToV i vd (VP nt n v) = liftM (VP nt n) (tmpToV i vd v) --- tmpToV i vd (VBind n b sc) = do b' <- fmapMB (tmpToV i vd) b --- let sc' = \x -> do x' <- sc x --- tmpToV (i + 1) vd x' --- return (VBind n b' sc') --- tmpToV i vd (VApp f a) = liftM2 VApp (tmpToV i vd f) (tmpToV i vd a) --- tmpToV i vd x = return x - -instance Eq Value where - (==) x y = getTT x == getTT y - where getTT v = evalState (quote 0 v) initEval - -class Quote a where - quote :: Int -> a -> Eval (TT Name) - -instance Quote Value where - quote i (VP nt n v) = liftM (P nt n) (quote i v) - quote i (VV x) = return $ V x - quote i (VBind _ n b sc) = do sc' <- sc (VTmp i) - b' <- quoteB b - liftM (Bind n b') (quote (i+1) sc') - where quoteB t = fmapMB (quote i) t - quote i (VBLet vd n t v sc) - = do sc' <- quote i sc - t' <- quote i t - v' <- quote i v - let sc'' = pToV (MN vd "vlet") (addBinder sc') - return (Bind n (Let t' v') sc'') - quote i (VApp f a) = liftM2 App (quote i f) (quote i a) - quote i (VType u) = return $ TType u - quote i VErased = return $ Erased - quote i VImpossible = return $ Impossible - quote i (VProj v j) = do v' <- quote i v - return (Proj v' j) - quote i (VConstant c) = return $ Constant c - quote i (VTmp x) = return $ V (i - x - 1) - -wknV :: Int -> Value -> Eval Value -wknV i (VV x) = return $ VV (x + i) -wknV i (VBind red n b sc) = do b' <- fmapMB (wknV i) b - return $ VBind red n b' (\x -> do x' <- sc x - wknV i x') -wknV i (VApp f a) = liftM2 VApp (wknV i f) (wknV i a) -wknV i t = return t - -convEq' ctxt x y = evalStateT (convEq ctxt x y) (0, []) - -convEq :: Context -> TT Name -> TT Name -> StateT UCs TC Bool -convEq ctxt = ceq [] where - ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs TC Bool - 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) - where - ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') - ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') - ceqB ps b b' = ceq ps (binderTy b) (binderTy b') - ceq ps (App fx ax) (App fy ay) = liftM2 (&&) (ceq ps fx fy) (ceq ps ax ay) - ceq ps (Constant x) (Constant y) = return (x == y) - ceq ps (TType x) (TType y) = do (v, cs) <- get - put (v, ULE x y : cs) - return True - ceq ps Erased _ = return True - ceq ps _ Erased = return True - ceq ps _ _ = return False - - caseeq ps (Case n cs) (Case n' cs') = caseeqA ((n,n'):ps) cs cs' - where - caseeqA ps (ConCase x i as sc : rest) (ConCase x' i' as' sc' : rest') - = do q1 <- caseeq (zip as as' ++ ps) sc sc' - q2 <- caseeqA ps rest rest' - return $ x == x' && i == i' && q1 && q2 - caseeqA ps (ConstCase x sc : rest) (ConstCase x' sc' : rest') - = do q1 <- caseeq ps sc sc' - q2 <- caseeqA ps rest rest' - return $ x == x' && q1 && q2 - caseeqA ps (DefaultCase sc : rest) (DefaultCase sc' : rest') - = liftM2 (&&) (caseeq ps sc sc') (caseeqA ps rest rest') - caseeqA ps [] [] = return True - caseeqA ps _ _ = return False - caseeq ps (STerm x) (STerm y) = ceq ps x y - caseeq ps (UnmatchedCase _) (UnmatchedCase _) = return True - caseeq ps _ _ = return False - - sameDefs ps x y = case (lookupDef x ctxt, lookupDef y ctxt) of - ([Function _ xdef], [Function _ ydef]) - -> ceq ((x,y):ps) xdef ydef - ([CaseOp _ _ _ _ xd], - [CaseOp _ _ _ _ yd]) - -> let (_, xdef) = cases_compiletime xd - (_, ydef) = cases_compiletime yd in - caseeq ((x,y):ps) xdef ydef - _ -> return False - --- SPECIALISATION ----------------------------------------------------------- --- We need too much control to be able to do this by tweaking the main --- evaluator - -spec :: Context -> Ctxt [Bool] -> Env -> TT Name -> Eval (TT Name) -spec ctxt statics genv tm = error "spec undefined" - --- CONTEXTS ----------------------------------------------------------------- - -{-| A definition is either a simple function (just an expression with a type), - a constant, which could be a data or type constructor, an axiom or as an - yet undefined function, or an Operator. - An Operator is a function which explains how to reduce. - A CaseOp is a function defined by a simple case tree -} - -data Def = Function !Type !Term - | TyDecl NameType !Type - | Operator Type Int ([Value] -> Maybe Value) - | CaseOp CaseInfo - !Type - ![Either Term (Term, Term)] -- original definition - ![([Name], Term, Term)] -- simplified for totality check definition - !CaseDefs --- [Name] SC -- Compile time case definition --- [Name] SC -- Run time cae definitions - -data CaseDefs = CaseDefs { - cases_totcheck :: !([Name], SC), - cases_compiletime :: !([Name], SC), - cases_inlined :: !([Name], SC), - cases_runtime :: !([Name], SC) - } - -data CaseInfo = CaseInfo { - case_inlinable :: Bool, - tc_dictionary :: Bool - } - -{-! -deriving instance Binary Def -!-} -{-! -deriving instance Binary CaseInfo -!-} -{-! -deriving instance Binary CaseDefs -!-} - -instance Show Def where - show (Function ty tm) = "Function: " ++ show (ty, tm) - show (TyDecl nt ty) = "TyDecl: " ++ show nt ++ " " ++ show ty - show (Operator ty _ _) = "Operator: " ++ show ty - show (CaseOp (CaseInfo inlc inlr) ty ps_in ps cd) - = let (ns, sc) = cases_compiletime cd - (ns_t, sc_t) = cases_totcheck cd - (ns', sc') = cases_runtime cd in - "Case: " ++ show ty ++ " " ++ show ps ++ "\n" ++ - "TOTALITY CHECK TIME:\n\n" ++ - show ns_t ++ " " ++ show sc_t ++ "\n\n" ++ - "COMPILE TIME:\n\n" ++ - show ns ++ " " ++ show sc ++ "\n\n" ++ - "RUN TIME:\n\n" ++ - show ns' ++ " " ++ show sc' ++ "\n\n" ++ - if inlc then "Inlinable\n" else "Not inlinable\n" - --- We need this for serialising Def. Fortunately, it never gets used because --- we'll never serialise a primitive operator - -instance Binary (a -> b) where - put x = return () - get = error "Getting a function" - -------- - --- Frozen => doesn't reduce --- Hidden => doesn't reduce and invisible to type checker - -data Accessibility = Public | Frozen | Hidden - deriving (Show, Eq) - --- | The result of totality checking -data Totality = Total [Int] -- ^ well-founded arguments - | Productive -- ^ productive - | Partial PReason - | Unchecked - deriving Eq - --- | Reasons why a function may not be total -data PReason = Other [Name] | Itself | NotCovering | NotPositive | UseUndef Name - | BelieveMe | Mutual [Name] | NotProductive - deriving (Show, Eq) - -instance Show Totality where - show (Total args)= "Total" -- ++ show args ++ " decreasing arguments" - show Productive = "Productive" -- ++ show args ++ " decreasing arguments" - show Unchecked = "not yet checked for totality" - show (Partial Itself) = "possibly not total as it is not well founded" - show (Partial NotCovering) = "not total as there are missing cases" - show (Partial NotPositive) = "not strictly positive" - show (Partial NotProductive) = "not productive" - show (Partial BelieveMe) = "not total due to use of believe_me in proof" - show (Partial (Other ns)) = "possibly not total due to: " ++ showSep ", " (map show ns) - show (Partial (Mutual ns)) = "possibly not total due to recursive path " ++ - showSep " --> " (map show ns) - -{-! -deriving instance Binary Accessibility -!-} - -{-! -deriving instance Binary Totality -!-} - -{-! -deriving instance Binary PReason -!-} - --- | Contexts used for global definitions and for proof state. They contain --- universe constraints and existing definitions. -data Context = MkContext { - uconstraints :: [UConstraint], - next_tvar :: Int, - definitions :: Ctxt (Def, Accessibility, Totality) - } deriving Show - --- | The initial empty context -initContext = MkContext [] 0 emptyContext - --- | Get the definitions from a context -ctxtAlist :: Context -> [(Name, Def)] -ctxtAlist ctxt = map (\(n, (d, a, t)) -> (n, d)) $ toAlist (definitions ctxt) - -veval ctxt env t = evalState (eval False ctxt [] env t []) initEval - -addToCtxt :: Name -> Term -> Type -> Context -> Context -addToCtxt n tm ty uctxt - = let ctxt = definitions uctxt - ctxt' = addDef n (Function ty tm, Public, Unchecked) ctxt in - uctxt { definitions = ctxt' } - -setAccess :: Name -> Accessibility -> Context -> Context -setAccess n a uctxt - = let ctxt = definitions uctxt - ctxt' = updateDef n (\ (d, _, t) -> (d, a, t)) ctxt in - uctxt { definitions = ctxt' } - -setTotal :: Name -> Totality -> Context -> Context -setTotal n t uctxt - = let ctxt = definitions uctxt - ctxt' = updateDef n (\ (d, a, _) -> (d, a, t)) ctxt in - uctxt { definitions = ctxt' } - -addCtxtDef :: Name -> Def -> Context -> Context -addCtxtDef n d c = let ctxt = definitions c - ctxt' = addDef n (d, Public, Unchecked) $! ctxt in - c { definitions = ctxt' } - -addTyDecl :: Name -> NameType -> Type -> Context -> Context -addTyDecl n nt ty uctxt - = let ctxt = definitions uctxt - ctxt' = addDef n (TyDecl nt ty, Public, Unchecked) ctxt in - uctxt { definitions = ctxt' } - -addDatatype :: Datatype Name -> Context -> Context -addDatatype (Data n tag ty cons) uctxt - = let ctxt = definitions uctxt - ty' = normalise uctxt [] ty - ctxt' = addCons 0 cons (addDef n - (TyDecl (TCon tag (arity ty')) ty, Public, Unchecked) ctxt) in - uctxt { definitions = ctxt' } - where - addCons tag [] ctxt = ctxt - addCons tag ((n, ty) : cons) ctxt - = let ty' = normalise uctxt [] ty in - addCons (tag+1) cons (addDef n - (TyDecl (DCon tag (arity ty')) ty, Public, Unchecked) ctxt) - --- FIXME: Too many arguments! Refactor all these Bools. -addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool -> - [Either Term (Term, Term)] -> - [([Name], Term, Term)] -> -- totality - [([Name], Term, Term)] -> -- compile time - [([Name], Term, Term)] -> -- inlined - [([Name], Term, Term)] -> -- run time - Type -> Context -> Context -addCasedef n ci@(CaseInfo alwaysInline tcdict) - tcase covering reflect asserted ps_in - ps_tot ps_inl ps_ct ps_rt ty uctxt - = let ctxt = definitions uctxt - access = case lookupDefAcc n False uctxt of - [(_, acc)] -> acc - _ -> Public - ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC ps_tot, - simpleCase tcase covering reflect CompileTime emptyFC ps_ct, - simpleCase tcase covering reflect CompileTime emptyFC ps_inl, - simpleCase tcase covering reflect RunTime emptyFC ps_rt) of - (OK (CaseDef args_tot sc_tot _), - OK (CaseDef args_ct sc_ct _), - OK (CaseDef args_inl sc_inl _), - OK (CaseDef args_rt sc_rt _)) -> - let inl = alwaysInline -- tcdict - inlc = (inl || small n args_ct sc_ct) && (not asserted) - inlr = inl || small n args_rt sc_rt - cdef = CaseDefs (args_tot, sc_tot) - (args_ct, sc_ct) - (args_inl, sc_inl) - (args_rt, sc_rt) in - addDef n (CaseOp (ci { case_inlinable = inlc }) - ty ps_in ps_tot cdef, - access, Unchecked) ctxt in - uctxt { definitions = ctxt' } - --- simplify a definition for totality checking -simplifyCasedef :: Name -> Context -> Context -simplifyCasedef n uctxt - = let ctxt = definitions uctxt - ctxt' = case lookupCtxt n ctxt of - [(CaseOp ci ty [] ps _, acc, tot)] -> - ctxt -- nothing to simplify (or already done...) - [(CaseOp ci ty ps_in ps cd, acc, tot)] -> - let ps_in' = map simpl ps_in - pdef = map debind ps_in' in - case simpleCase False True False CompileTime emptyFC pdef of - OK (CaseDef args sc _) -> - addDef n (CaseOp ci - ty ps_in' ps (cd { cases_totcheck = (args, sc) }), - acc, tot) ctxt - Error err -> error (show err) - _ -> ctxt in - uctxt { definitions = ctxt' } - where - depat acc (Bind n (PVar t) sc) - = depat (n : acc) (instantiate (P Bound n t) sc) - depat acc x = (acc, x) - debind (Right (x, y)) = let (vs, x') = depat [] x - (_, y') = depat [] y in - (vs, x', y') - debind (Left x) = let (vs, x') = depat [] x in - (vs, x', Impossible) - simpl (Right (x, y)) = Right (x, simplify uctxt [] y) - simpl t = t - -addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) -> - Context -> Context -addOperator n ty a op uctxt - = let ctxt = definitions uctxt - ctxt' = addDef n (Operator ty a op, Public, Unchecked) ctxt in - uctxt { definitions = ctxt' } - -tfst (a, _, _) = a - -lookupNames :: Name -> Context -> [Name] -lookupNames n ctxt - = let ns = lookupCtxtName n (definitions ctxt) in - map fst ns - -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 :: Name -> Context -> Bool -isConName n ctxt = isTConName n ctxt || isDConName n ctxt - -isTConName :: Name -> Context -> Bool -isTConName n ctxt - = or $ do def <- lookupCtxt n (definitions ctxt) - case tfst def of - (TyDecl (TCon _ _) _) -> return True - _ -> return False - -isDConName :: Name -> Context -> Bool -isDConName n ctxt - = or $ do def <- lookupCtxt n (definitions ctxt) - case tfst def of - (TyDecl (DCon _ _) _) -> return True - _ -> return False - -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 :: 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) - (CaseOp _ ty _ _ _, a, _) -> return (P Ref n ty, a) - (Operator ty _ _, a, _) -> return (P Ref n ty, a) - case snd p of - Hidden -> [] - _ -> return (fst p) - -lookupDef :: Name -> Context -> [Def] -lookupDef n ctxt = map tfst $ lookupCtxt n (definitions ctxt) - -lookupDefAcc :: Name -> Bool -> Context -> - [(Def, Accessibility)] -lookupDefAcc n mkpublic ctxt - = map mkp $ lookupCtxt n (definitions ctxt) - -- io_bind a special case for REPL prettiness - where mkp (d, a, _) = if mkpublic && (not (n == UN "io_bind" || n == UN "io_return")) - then (d, Public) else (d, a) - -lookupTotal :: Name -> Context -> [Totality] -lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt) - where mkt (d, a, t) = t - -lookupNameTotal :: Name -> Context -> [(Name, Totality)] -lookupNameTotal n = map (\(n, (_, _, t)) -> (n, t)) . lookupCtxtName n . definitions - - -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)) - -lookupTyEnv :: Name -> Env -> Maybe (Int, Type) -lookupTyEnv n env = li n 0 env where - li n i [] = Nothing - li n i ((x, b): xs) - | n == x = Just (i, binderTy b) - | otherwise = li n (i+1) xs - diff --git a/src/Core/Execute.hs b/src/Core/Execute.hs deleted file mode 100644 --- a/src/Core/Execute.hs +++ /dev/null @@ -1,540 +0,0 @@ -{-# LANGUAGE PatternGuards, ExistentialQuantification, CPP #-} -module Core.Execute (execute) where - -import Idris.AbsSyntax -import Idris.AbsSyntaxTree -import IRTS.Lang(FType(..)) - -import Idris.Primitives(Prim(..), primitives) - -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 - -#ifdef IDRIS_FFI -import Foreign.LibFFI -import Foreign.C.String -import Foreign.Marshal.Alloc (free) -import Foreign.Ptr -#endif - -import System.IO - -#ifndef IDRIS_FFI -execute :: Term -> Idris Term -execute tm = fail "libffi not supported, rebuild Idris with -f FFI" -#else --- else is rest of file -readMay :: (Read a) => String -> Maybe a -readMay s = case reads s of - [(x, "")] -> Just x - _ -> Nothing - -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 ++ " <>" - show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")" - show (EType _) = "Type" - show EErased = "[__]" - show (EConstant c) = show c - show (EPtr p) = "<>" - show (EThunk i) = "<>" - show (EHandle 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 i t) = GHole i <$> 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 . 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 _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun - doExec env ctxt tm - [CaseOp _ _ _ _ (CaseDefs _ (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 "unsafePerformPrimIO") _) (ty:action:rest) | (prim__IO, [_, v]) <- unApplyV action = - execApp' env ctxt v rest - -execApp' env ctxt (EP _ (UN "prim_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 "prim_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 "mkForeignPrim") _) (_:fn:EConstant (Str arg):_:rest) - | Just (FFun "putStr" _ _) <- foreignFromTT fn - = do execIO (putStr arg) - execApp' env ctxt ioUnit rest -execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:_:EHandle h:_:rest) - | Just (FFun "idris_readStr" _ _) <- foreignFromTT fn - = do contents <- execIO $ hGetLine h - execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest -execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_: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)) (tail rest) - -execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_: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 (tail rest) - -execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest) - | Just (FFun "fileClose" _ _) <- foreignFromTT fn - = do execIO $ hClose h - execApp' env ctxt ioUnit (tail rest) - -execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_: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 (tail rest) - --- Throw away the 'World' argument to the foreign function - -execApp' env ctxt f@(EP _ (UN "mkForeignPrim") _) args@(ty:fn:xs) - | Just (FFun f argTs retT) <- foreignFromTT fn - , length xs >= length argTs = - do let (args', xs') = (take (length argTs) xs, -- foreign args - drop (length argTs + 1) xs) -- rest - res <- stepForeign (ty:fn:args') - case res of - Nothing -> fail $ "Could not call foreign function \"" ++ f ++ - "\" with args " ++ show args - Just r -> return (mkEApp r xs') - | otherwise = return (mkEApp f args) - -execApp' env ctxt c@(EP (DCon _ arity) n _) args = - do args' <- mapM tryForce (take arity args) - let restArgs = drop arity args - execApp' env ctxt (mkEApp c args') restArgs - -execApp' env ctxt c@(EP (TCon _ arity) n _) args = - do args' <- mapM tryForce (take arity args) - let restArgs = drop arity args - execApp' env ctxt (mkEApp c args') restArgs - -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 _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun - do rhs <- doExec env ctxt tm - execApp' env ctxt rhs args - [CaseOp _ _ _ _ (CaseDefs _ (ns, sc) _ _)] -> - do res <- execCase env ctxt ns sc args - return $ fromMaybe (mkEApp f args) res - thing -> return $ mkEApp f args -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) - --- | Look up primitive operations in the global table and transform them into ExecVal functions -getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal) -getOp (UN "prim__believe_me") [_, _, x] = Just (return x) -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 ++ "\n"))) -getOp n args = getPrim n primitives >>= flip applyPrim args - where getPrim :: Name -> [Prim] -> Maybe ([ExecVal] -> Maybe ExecVal) - getPrim n [] = Nothing - getPrim n ((Prim pn _ arity def _ _) : prims) | n == pn = Just $ execPrim def - | otherwise = getPrim n prims - - execPrim :: ([Const] -> Maybe Const) -> [ExecVal] -> Maybe ExecVal - execPrim f args = EConstant <$> (mapM getConst args >>= f) - - getConst (EConstant c) = Just c - getConst _ = Nothing - - applyPrim :: ([ExecVal] -> Maybe ExecVal) -> [ExecVal] -> Maybe (Exec ExecVal) - applyPrim fn args = return <$> fn 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 (FArith ty) = AType ty - 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 - maybe (return Nothing) (\f -> Just . ioWrap <$> call' f args retType) fn - where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal - call' (Fun _ h) args (FArith (ATInt ITNative)) = do - res <- execIO $ callFFI h retCInt (prepArgs args) - return (EConstant (I (fromIntegral res))) - call' (Fun _ h) args (FArith (ATInt (ITFixed IT8))) = do - res <- execIO $ callFFI h retCChar (prepArgs args) - return (EConstant (B8 (fromIntegral res))) - call' (Fun _ h) args (FArith (ATInt (ITFixed IT16))) = do - res <- execIO $ callFFI h retCWchar (prepArgs args) - return (EConstant (B16 (fromIntegral res))) - call' (Fun _ h) args (FArith (ATInt (ITFixed IT32))) = do - res <- execIO $ callFFI h retCInt (prepArgs args) - return (EConstant (B32 (fromIntegral res))) - call' (Fun _ h) args (FArith (ATInt (ITFixed IT64))) = do - res <- execIO $ callFFI h retCLong (prepArgs args) - return (EConstant (B64 (fromIntegral res))) - call' (Fun _ h) args (FArith ATFloat) = do - res <- execIO $ callFFI h retCDouble (prepArgs args) - return (EConstant (Fl (realToFrac res))) - call' (Fun _ h) args (FArith (ATInt ITChar)) = 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 = EPtr <$> (execIO $ callFFI h (retPtr retVoid) (prepArgs args)) - call' (Fun _ h) args FUnit = do _ <- 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 (FArith (ATInt ITNative)) - "ITChar" -> Just (FArith (ATInt ITChar)) - "IT8" -> Just (FArith (ATInt (ITFixed IT8))) - "IT16" -> Just (FArith (ATInt (ITFixed IT16))) - "IT32" -> Just (FArith (ATInt (ITFixed IT32))) - "IT64" -> Just (FArith (ATInt (ITFixed IT64))) - _ -> Nothing -getFTy (EP _ (UN t) _) = - case t of - "FFloat" -> Just (FArith ATFloat) - "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) = let ffun = foreignFromTT fn - in case (call <$> ffun) of - Just f -> f args - Nothing -> return Nothing -stepForeign _ = fail "Tried to call foreign function that wasn't mkForeignPrim" - -mapMaybeM :: (Functor m, Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM f [] = return [] -mapMaybeM f (x:xs) = do rest <- mapMaybeM f xs - maybe rest (:rest) <$> f x -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) - -#endif diff --git a/src/Core/ProofState.hs b/src/Core/ProofState.hs deleted file mode 100644 --- a/src/Core/ProofState.hs +++ /dev/null @@ -1,832 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-} - -{- Implements a proof state, some primitive tactics for manipulating - proofs, and some high level commands for introducing new theorems, - evaluation/checking inside the proof system, etc. --} - -module Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus, - Tactic(..), Goal(..), processTactic, - dropGiven, keepGiven) where - -import Core.Typecheck -import Core.Evaluate -import Core.TT -import Core.Unify - -import Control.Monad.State -import Control.Applicative hiding (empty) -import Data.List -import Debug.Trace - -import Util.Pretty - -data ProofState = PS { thname :: Name, - holes :: [Name], -- holes still to be solved - usedns :: [Name], -- used names, don't use again - nextname :: Int, -- name supply - pterm :: Term, -- current proof term - 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], - deferred :: [Name], -- names we'll need to define - instances :: [Name], -- instance arguments (for type classes) - previous :: Maybe ProofState, -- for undo - context :: Context, - plog :: String, - unifylog :: Bool, - done :: Bool - } - -data Goal = GD { premises :: Env, - goalType :: Binder Term - } - -data Tactic = Attack - | Claim Name Raw - | Reorder Name - | Exact Raw - | Fill Raw - | MatchFill Raw - | PrepFill Name [Name] - | CompleteFill - | Regret - | Solve - | StartUnify Name - | EndUnify - | Compute - | ComputeLet Name - | Simplify - | HNF_Compute - | EvalIn Raw - | CheckIn Raw - | Intro (Maybe Name) - | IntroTy Raw (Maybe Name) - | Forall Name Raw - | LetBind Name Raw Raw - | ExpandLet Name Term - | Rewrite Raw - | Equiv Raw - | PatVar Name - | PatBind Name - | Focus Name - | Defer Name - | DeferType Name Raw [Name] - | Instance Name - | SetInjective Name - | MoveLast Name - | MatchProblems - | UnifyProblems - | ProofState - | Undo - | QED - deriving Show - --- 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 _ _ _) - = let OK g = goal (Just h) tm - wkenv = premises g in - "Other goals: " ++ show hs ++ "\n" ++ - showPs wkenv (reverse wkenv) ++ "\n" ++ - "-------------------------------- (" ++ show nm ++ - ") -------\n " ++ - show h ++ " : " ++ showG wkenv (goalType g) ++ "\n" - where showPs env [] = "" - showPs env ((n, Let t v):bs) - = " " ++ show n ++ " : " ++ - showEnv env ({- normalise ctxt env -} t) ++ " = " ++ - showEnv env ({- normalise ctxt env -} v) ++ - "\n" ++ showPs env bs - showPs env ((n, b):bs) - = " " ++ show n ++ " : " ++ - showEnv env ({- normalise ctxt env -} (binderTy b)) ++ - "\n" ++ showPs env bs - showG ps (Guess t v) = showEnv ps ({- normalise ctxt ps -} t) ++ - " =?= " ++ showEnv ps v - showG ps b = showEnv ps (binderTy b) - -instance Pretty ProofState where - 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 _ _ _) = - let OK g = goal (Just h) tm in - let wkEnv = premises g in - text "Other goals" <+> colon <+> pretty hs $$ - prettyPs wkEnv (reverse wkEnv) $$ - text "---------- " <+> text "Focussing on" <> colon <+> pretty nm <+> text " ----------" $$ - pretty h <+> colon <+> prettyGoal wkEnv (goalType g) - where - prettyGoal ps (Guess t v) = - if size v > breakingSize then - prettyEnv ps t <+> text "=?=" $$ - nest nestingSize (prettyEnv ps v) - else - prettyEnv ps t <+> text "=?=" <+> prettyEnv ps v - prettyGoal ps b = prettyEnv ps $ binderTy b - - prettyPs env [] = empty - prettyPs env ((n, Let t v):bs) = - nest nestingSize (pretty n <+> colon <+> - if size v > breakingSize then - prettyEnv env t <+> text "=" $$ - nest nestingSize (prettyEnv env v) $$ - nest nestingSize (prettyPs env bs) - else - prettyEnv env t <+> text "=" <+> prettyEnv env v $$ - nest nestingSize (prettyPs env bs)) - prettyPs env ((n, b):bs) = - if size (binderTy b) > breakingSize then - nest nestingSize (pretty n <+> colon <+> prettyEnv env (binderTy b) <+> prettyPs env bs) - else - nest nestingSize (pretty n <+> colon <+> prettyEnv env (binderTy b) $$ - nest nestingSize (prettyPs env bs)) - -same Nothing n = True -same (Just x) n = x == n - -hole (Hole _) = True -hole (Guess _ _) = True -hole _ = False - -holeName i = MN i "hole" - -qshow :: Fails -> String -qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs) - -match_unify' :: Context -> Env -> TT Name -> TT Name -> - StateT TState TC [(Name, TT Name)] -match_unify' ctxt env topx topy = - do ps <- get - let dont = dontunify ps - u <- lift $ match_unify ctxt env topx topy dont (holes ps) - let (h, ns) = unified ps - put (ps { unified = (h, u ++ ns) }) - return u - -unify' :: Context -> Env -> TT Name -> TT Name -> - StateT TState TC [(Name, TT Name)] -unify' ctxt env topx topy = - do ps <- get - let dont = dontunify ps - (u, fails) <- traceWhen (unifylog ps) - ("Trying " ++ show (topx, topy) ++ - " in " ++ show env ++ - "\nHoles: " ++ show (holes ps) ++ "\n") $ - lift $ unify ctxt env topx topy dont (holes ps) - traceWhen (unifylog ps) - ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++ - "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails - ++ "\nCurrent problems:\n" ++ qshow (problems ps) --- ++ show (pterm ps) - ++ "\n----------") $ - case fails of --- [] -> return u - err -> - do ps <- get - let (h, ns) = unified ps - let (ns', probs') = updateProblems (context ps) (u ++ ns) - (err ++ problems ps) - (injective ps) - (holes ps) - put (ps { problems = probs', - unified = (h, ns') }) - return u - -getName :: Monad m => String -> StateT TState m Name -getName tag = do ps <- get - let n = nextname ps - put (ps { nextname = n+1 }) - return $ MN n tag - -action :: Monad m => (ProofState -> ProofState) -> StateT TState m () -action a = do ps <- get - put (a ps) - -addLog :: Monad m => String -> StateT TState m () -addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" }) - -newProof :: Name -> Context -> Type -> ProofState -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, []) [] - Nothing [] [] - [] [] - Nothing ctxt "" False False - -type TState = ProofState -- [TacticAction]) -type RunTactic = Context -> Env -> Term -> StateT TState TC Term -type Hole = Maybe Name -- Nothing = default hole, first in list in proof state - -envAtFocus :: ProofState -> TC Env -envAtFocus ps - | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps) - return (premises g) - | otherwise = fail "No holes" - -goalAtFocus :: ProofState -> TC (Binder Type) -goalAtFocus ps - | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps) - return (goalType g) - | otherwise = Error . Msg $ "No goal in " ++ show (holes ps) ++ show (pterm ps) - -goal :: Hole -> Term -> TC Goal -goal h tm = g [] tm where - g env (Bind n b@(Guess _ _) sc) - | same h n = return $ GD env b - | otherwise - = gb env b `mplus` g ((n, b):env) sc - g env (Bind n b sc) | hole b && same h n = return $ GD env b - | otherwise - = g ((n, b):env) sc `mplus` gb env b - g env (App f a) = g env f `mplus` g env a - g env t = fail "Can't find hole" - - gb env (Let t v) = g env v `mplus` g env t - gb env (Guess t v) = g env v `mplus` g env t - gb env t = g env (binderTy t) - -tactic :: Hole -> RunTactic -> StateT TState TC () -tactic h f = do ps <- get - (tm', _) <- atH (context ps) [] (pterm ps) - ps <- get -- might have changed while processing - put (ps { pterm = tm' }) - where - updated o = do o' <- o - return (o', True) - - ulift2 c env op a b - = do (b', u) <- atH c env b - if u then return (op a b', True) - else do (a', u) <- atH c env a - return (op a' b', u) - - -- Search the things most likely to contain the binding first! - - atH :: Context -> Env -> Term -> StateT TState TC (Term, Bool) - atH c env binder@(Bind n b@(Guess t v) sc) - | same h n = updated (f c env binder) - | otherwise - = do -- binder first - (b', u) <- ulift2 c env Guess t v - if u then return (Bind n b' sc, True) - else do (sc', u) <- atH c ((n, b) : env) sc - return (Bind n b' sc', u) - atH c env binder@(Bind n b sc) - | hole b && same h n = updated (f c env binder) - | otherwise -- scope first - = do (sc', u) <- atH c ((n, b) : env) sc - if u then return (Bind n b sc', True) - else do (b', u) <- atHb c env b - return (Bind n b' sc', u) - atH c env (App f a) = ulift2 c env App f a - atH c env t = return (t, False) - - atHb c env (Let t v) = ulift2 c env Let t v - atHb c env (Guess t v) = ulift2 c env Guess t v - atHb c env t = do (ty', u) <- atH c env (binderTy t) - return (t { binderTy = ty' }, u) - -computeLet :: Context -> Name -> Term -> Term -computeLet ctxt n tm = cl [] tm where - cl env (Bind n' (Let t v) sc) - | n' == n = let v' = normalise ctxt env v in - Bind n' (Let t v') sc - cl env (Bind n' b sc) = Bind n' (fmap (cl env) b) (cl ((n, b):env) sc) - cl env (App f a) = App (cl env f) (cl env a) - cl env t = t - -attack :: RunTactic -attack ctxt env (Bind x (Hole t) sc) - = do h <- getName "hole" - action (\ps -> ps { holes = h : holes ps }) - return $ Bind x (Guess t (newtm h)) sc - where - newtm h = Bind h (Hole t) (P Bound h t) -attack ctxt env _ = fail "Not an attackable hole" - -claim :: Name -> Raw -> RunTactic -claim n ty ctxt env t = - do (tyv, tyt) <- lift $ check ctxt env ty - lift $ isType ctxt env tyt - action (\ps -> let (g:gs) = holes ps in - ps { holes = g : n : gs } ) - return $ Bind n (Hole tyv) t -- (weakenTm 1 t) - -reorder_claims :: RunTactic -reorder_claims ctxt env t - = -- trace (showSep "\n" (map show (scvs t))) $ - let (bs, sc) = scvs t [] - newbs = reverse (sortB (reverse bs)) in - traceWhen (bs /= newbs) (show bs ++ "\n ==> \n" ++ show newbs) $ - return (bindAll newbs sc) - where scvs (Bind n b@(Hole _) sc) acc = scvs sc ((n, b):acc) - scvs sc acc = (reverse acc, sc) - - sortB :: [(Name, Binder (TT Name))] -> [(Name, Binder (TT Name))] - sortB [] = [] - sortB (x:xs) | all (noOcc x) xs = x : sortB xs - | otherwise = sortB (insertB x xs) - - insertB x [] = [x] - insertB x (y:ys) | all (noOcc x) (y:ys) = x : y : ys - | otherwise = y : insertB x ys - - noOcc (n, _) (_, Let t v) = noOccurrence n t && noOccurrence n v - noOcc (n, _) (_, Guess t v) = noOccurrence n t && noOccurrence n v - noOcc (n, _) (_, b) = noOccurrence n (binderTy b) - -focus :: Name -> RunTactic -focus n ctxt env t = do action (\ps -> let hs = holes ps in - if n `elem` hs - then ps { holes = n : (hs \\ [n]) } - else ps) - ps <- get - return t - -movelast :: Name -> RunTactic -movelast n ctxt env t = do action (\ps -> let hs = holes ps in - if n `elem` hs - then ps { holes = (hs \\ [n]) ++ [n] } - else ps) - return t - -instanceArg :: Name -> RunTactic -instanceArg n ctxt env (Bind x (Hole t) sc) - = do action (\ps -> let hs = holes ps - is = instances ps in - ps { holes = (hs \\ [x]) ++ [x], - instances = x:is }) - return (Bind x (Hole t) sc) - -setinj :: Name -> RunTactic -setinj n ctxt env (Bind x (Hole t) sc) - = do action (\ps -> let is = injective ps in - ps { injective = n : is }) - return (Bind x (Hole t) sc) - -defer :: Name -> RunTactic -defer n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' = - do action (\ps -> let hs = holes ps in - ps { holes = hs \\ [x] }) - return (Bind n (GHole (length env) (mkTy (reverse env) t)) - (mkApp (P Ref n ty) (map getP (reverse env)))) - where - mkTy [] t = t - mkTy ((n,b) : bs) t = Bind n (Pi (binderTy b)) (mkTy bs t) - - getP (n, b) = P Bound n (binderTy b) - --- as defer, but build the type and application explicitly -deferType :: Name -> Raw -> [Name] -> RunTactic -deferType n fty_in args ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' = - do (fty, _) <- lift $ check ctxt env fty_in - action (\ps -> let hs = holes ps - ds = deferred ps in - ps { holes = hs \\ [x], - deferred = n : ds }) - return (Bind n (GHole 0 fty) - (mkApp (P Ref n ty) (map getP args))) - where - getP n = case lookup n env of - Just b -> P Bound n (binderTy b) - Nothing -> error ("deferType can't find " ++ show n) - -regret :: RunTactic -regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc = - do action (\ps -> let hs = holes ps in - ps { holes = hs \\ [x] }) - return sc -regret ctxt env (Bind x (Hole t) _) - = fail $ show x ++ " : " ++ show t ++ " is not solved..." - -exact :: Raw -> RunTactic -exact guess ctxt env (Bind x (Hole ty) sc) = - do (val, valty) <- lift $ check ctxt env guess - lift $ converts ctxt env valty ty - return $ Bind x (Guess ty val) sc -exact _ _ _ _ = fail "Can't fill here." - --- As exact, but attempts to solve other goals by unification - -fill :: Raw -> RunTactic -fill guess ctxt env (Bind x (Hole ty) sc) = - do (val, valty) <- lift $ check ctxt env guess --- let valtyn = normalise ctxt env valty --- let tyn = normalise ctxt env ty - ns <- unify' ctxt env valty ty - ps <- get - let (uh, uns) = unified ps --- put (ps { unified = (uh, uns ++ ns) }) --- addLog (show (uh, uns ++ ns)) - return $ Bind x (Guess ty val) sc -fill _ _ _ _ = fail "Can't fill here." - --- As fill, but attempts to solve other goals by matching - -match_fill :: Raw -> RunTactic -match_fill guess ctxt env (Bind x (Hole ty) sc) = - do (val, valty) <- lift $ check ctxt env guess --- let valtyn = normalise ctxt env valty --- let tyn = normalise ctxt env ty - ns <- match_unify' ctxt env valty ty - ps <- get - let (uh, uns) = unified ps --- put (ps { unified = (uh, uns ++ ns) }) --- addLog (show (uh, uns ++ ns)) - return $ Bind x (Guess ty val) sc -match_fill _ _ _ _ = fail "Can't fill here." - -prep_fill :: Name -> [Name] -> RunTactic -prep_fill f as ctxt env (Bind x (Hole ty) sc) = - do let val = mkApp (P Ref f Erased) (map (\n -> P Ref n Erased) as) - return $ Bind x (Guess ty val) sc -prep_fill f as ctxt env t = fail $ "Can't prepare fill at " ++ show t - -complete_fill :: RunTactic -complete_fill ctxt env (Bind x (Guess ty val) sc) = - do let guess = forget val - (val', valty) <- lift $ check ctxt env guess - ns <- unify' ctxt env valty ty - ps <- get - let (uh, uns) = unified ps --- put (ps { unified = (uh, uns ++ ns) }) - 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 --- x val (problems ps), - -- dontunify = dontunify ps \\ [x], - -- unified = (uh, uns ++ [(x, val)]), - instances = instances ps \\ [x] }) - let tm' = instantiate val (pToV x sc) in - return tm' - | 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 -introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = - do let n = case mn of - Just name -> name - Nothing -> x - let t' = case t of - x@(Bind y (Pi s) _) -> x - _ -> hnf ctxt env t - (tyv, tyt) <- lift $ check ctxt env ty --- ns <- lift $ unify ctxt env tyv t' - case t' of - Bind y (Pi s) t -> let t' = instantiate (P Bound n s) (pToV y t) in - do ns <- unify' ctxt env s tyv - ps <- get - let (uh, uns) = unified ps --- put (ps { unified = (uh, uns ++ ns) }) - return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t')) - _ -> lift $ tfail $ CantIntroduce t' -introTy ty n ctxt env _ = fail "Can't introduce here." - -intro :: Maybe Name -> RunTactic -intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = - do let n = case mn of - Just name -> name - Nothing -> x - let t' = case t of - x@(Bind y (Pi s) _) -> x - _ -> hnf ctxt env t - case t' of - 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')) - _ -> 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 - unify' ctxt env tyt (TType (UVar 0)) - unify' ctxt env t (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" - -patvar :: Name -> RunTactic -patvar n ctxt env (Bind x (Hole t) sc) = - do action (\ps -> ps { holes = holes ps \\ [x] }) - return $ Bind n (PVar t) (instantiate (P Bound n t) (pToV x sc)) -patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm - -letbind :: Name -> Raw -> Raw -> RunTactic -letbind n ty val ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = - do (tyv, tyt) <- lift $ check ctxt env ty - (valv, valt) <- lift $ check ctxt env val - lift $ isType ctxt env tyt - return $ Bind n (Let tyv valv) (Bind x (Hole t) (P Bound x t)) -letbind n ty val ctxt env _ = fail "Can't let bind here" - -expandLet :: Name -> Term -> RunTactic -expandLet n v ctxt env tm = - return $ subst n v tm - -rewrite :: Raw -> RunTactic -rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' = - do (tmv, tmt) <- lift $ check ctxt env tm - let tmt' = normalise ctxt env tmt - case unApply tmt' of - (P _ (UN "=") _, [lt,rt,l,r]) -> - do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t) - let newt = mkP l r l t - let sc = forget $ (Bind x (Hole newt) - (mkApp (P Ref (UN "replace") (TType (UVal 0))) - [lt, l, r, p, tmv, xp])) - (scv, sct) <- lift $ check ctxt env sc - return scv - _ -> fail "Not an equality type" - where - -- to make the P for rewrite, replace syntactic occurrences of l in ty with - -- an x, and put \x : lt in front - mkP lt l r ty | l == ty = lt - mkP lt l r (App f a) = let f' = if (r /= f) then mkP lt l r f else f - a' = if (r /= a) then mkP lt l r a else a in - App f' a' - mkP lt l r (Bind n b sc) - = let b' = mkPB b - sc' = if (r /= sc) then mkP lt l r sc else sc in - Bind n b' sc' - where mkPB (Let t v) = let t' = if (r /= t) then mkP lt l r t else t - v' = if (r /= v) then mkP lt l r v else v in - Let t' v' - mkPB b = let ty = binderTy b - ty' = if (r /= ty) then mkP lt l r ty else ty in - b { binderTy = ty' } - mkP lt l r x = x - - rname = MN 0 "replaced" -rewrite _ _ _ _ = fail "Can't rewrite here" - -equiv :: Raw -> RunTactic -equiv tm ctxt env (Bind x (Hole t) sc) = - do (tmv, tmt) <- lift $ check ctxt env tm - lift $ converts ctxt env tmv t - return $ Bind x (Hole tmv) sc -equiv tm ctxt env _ = fail "Can't equiv here" - -patbind :: Name -> RunTactic -patbind n ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = - do let t' = case t of - x@(Bind y (PVTy s) t) -> x - _ -> hnf ctxt env t - case t' of - Bind y (PVTy s) t -> let t' = instantiate (P Bound n s) (pToV y t) in - return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t')) - _ -> fail "Nothing to pattern bind" -patbind n ctxt env _ = fail "Can't pattern bind here" - -compute :: RunTactic -compute ctxt env (Bind x (Hole ty) sc) = - do return $ Bind x (Hole (normalise ctxt env ty)) sc -compute ctxt env t = return t - -hnf_compute :: RunTactic -hnf_compute ctxt env (Bind x (Hole ty) sc) = - do let ty' = hnf ctxt env ty in --- trace ("HNF " ++ show (ty, ty')) $ - return $ Bind x (Hole ty') sc -hnf_compute ctxt env t = return t - --- reduce let bindings only -simplify :: RunTactic -simplify ctxt env (Bind x (Hole ty) sc) = - do return $ Bind x (Hole (specialise ctxt env [] ty)) sc -simplify ctxt env t = return t - -check_in :: Raw -> RunTactic -check_in t ctxt env tm = - do (val, valty) <- lift $ check ctxt env t - addLog (showEnv env val ++ " : " ++ showEnv env valty) - return tm - -eval_in :: Raw -> RunTactic -eval_in t ctxt env tm = - do (val, valty) <- lift $ check ctxt env t - let val' = normalise ctxt env val - let valty' = normalise ctxt env valty - addLog (showEnv env val ++ " : " ++ - showEnv env valty ++ --- " in " ++ show env ++ - " ==>\n " ++ - showEnv env val' ++ " : " ++ - showEnv env valty') - return tm - -start_unify :: Name -> RunTactic -start_unify n ctxt env tm = do -- action (\ps -> ps { unified = (n, []) }) - return tm - -tmap f (a, b, c) = (f a, b, c) - -solve_unified :: RunTactic -solve_unified ctxt env tm = - do ps <- get - let (_, ns) = unified ps - let unify = dropGiven (dontunify ps) ns (holes ps) - action (\ps -> ps { holes = holes ps \\ map fst unify }) - action (\ps -> ps { pterm = updateSolved unify (pterm ps) }) - return (updateSolved unify tm) - where - -dropGiven du [] hs = [] -dropGiven du ((n, P Bound t ty) : us) hs - | n `elem` du && not (t `elem` du) - && n `elem` hs && t `elem` hs - = (t, P Bound n ty) : dropGiven du us hs -dropGiven du (u@(n, _) : us) hs - | n `elem` du = dropGiven du us hs --- 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) - | Just v <- lookup n xs = instantiate v (pToV n (updateSolved' xs t)) -updateSolved' xs (Bind n b t) - | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t) -updateSolved' xs (App f a) = App (updateSolved' xs f) (updateSolved' xs a) -updateSolved' xs (P _ n _) - | Just v <- lookup n xs = v -updateSolved' xs t = t - -updateEnv ns [] = [] -updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env - -updateError ns (CantUnify b l r e xs sc) - = CantUnify b (updateSolved ns l) (updateSolved ns r) (updateError ns e) xs sc -updateError ns e = e - -solveInProblems x val [] = [] -solveInProblems x val ((l, r, env, err) : ps) - = ((instantiate val (pToV x l), instantiate val (pToV x r), - updateEnv [(x, val)] env, err) : solveInProblems x val ps) - -updateProblems ctxt ns ps inj holes = up ns ps where - up ns [] = (ns, []) - up ns ((x, y, env, err) : ps) = - let x' = updateSolved ns x - y' = updateSolved ns y - err' = updateError ns err - env' = updateEnv ns env in - case unify ctxt env' x' y' inj holes of - OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $ - up (ns ++ v) ps - _ -> let (ns', ps') = up ns ps in - (ns', (x',y',env',err') : ps') - --- attempt to solve remaining problems with match_unify -matchProblems ctxt ps inj holes = up [] ps where - up ns [] = (ns, []) - up ns ((x, y, env, err) : ps) = - let x' = updateSolved ns x - y' = updateSolved ns y - err' = updateError ns err - env' = updateEnv ns env in - case match_unify ctxt env' x' y' inj holes of - OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $ - up (ns ++ v) ps - _ -> let (ns', ps') = up ns ps in - (ns', (x',y',env',err') : ps') - -processTactic :: Tactic -> ProofState -> TC (ProofState, String) -processTactic QED ps = case holes ps of - [] -> do let tm = {- normalise (context ps) [] -} (pterm ps) - (tm', ty', _) <- recheck (context ps) [] (forget tm) tm - return (ps { done = True, pterm = tm' }, - "Proof complete: " ++ showEnv [] tm') - _ -> fail "Still holes to fill." -processTactic ProofState ps = return (ps, showEnv [] (pterm ps)) -processTactic Undo ps = case previous ps of - Nothing -> fail "Nothing to undo." - Just pold -> return (pold, "") -processTactic EndUnify ps - = let (h, ns_in) = unified ps - ns = dropGiven (dontunify ps) ns_in (holes ps) - 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_in ++ "\n" ++ show ns'') $ -- ++ " in " ++ show (pterm ps)) $ - updateSolved ns'' (pterm ps) in - return (ps { pterm = tm', - unified = (h, []), - problems = probs', - holes = holes ps \\ map fst ns'' }, "") -processTactic (Reorder n) ps - = do ps' <- execStateT (tactic (Just n) reorder_claims) ps - return (ps' { previous = Just ps, plog = "" }, plog ps') -processTactic (ComputeLet n) ps - = return (ps { pterm = computeLet (context ps) n (pterm ps) }, "") -processTactic UnifyProblems ps - = let (ns', probs') = updateProblems (context ps) [] - (problems ps) - (injective ps) - (holes ps) - pterm' = updateSolved ns' (pterm ps) in - return (ps { pterm = pterm', solved = Nothing, problems = probs', - previous = Just ps, plog = "", - holes = holes ps \\ (map fst ns') }, plog ps) -processTactic MatchProblems ps - = let (ns', probs') = matchProblems (context ps) - (problems ps) - (injective ps) - (holes ps) - pterm' = updateSolved ns' (pterm ps) in - return (ps { pterm = pterm', solved = Nothing, problems = probs', - previous = Just ps, plog = "", - holes = holes ps \\ (map fst ns') }, plog ps) -processTactic t ps - = case holes ps of - [] -> fail "Nothing to fill in." - (h:_) -> do ps' <- execStateT (process t h) ps - let (ns', probs') - = case solved ps' of - Just s -> updateProblems (context ps') - [s] (problems ps') - (injective ps') - (holes ps') - _ -> ([], problems ps') - -- rechecking problems may find more solutions, so - -- apply them here - let pterm'' = updateSolved ns' (pterm ps') - return (ps' { pterm = pterm'', - solved = Nothing, - problems = probs', - previous = Just ps, plog = "", - holes = holes ps' \\ (map fst ns')}, plog ps') - -process :: Tactic -> Name -> StateT TState TC () -process EndUnify _ - = do ps <- get - let (h, _) = unified ps - tactic (Just h) solve_unified -process t h = tactic (Just h) (mktac t) - where mktac Attack = attack - mktac (Claim n r) = claim n r - mktac (Exact r) = exact r - mktac (Fill r) = fill r - mktac (MatchFill r) = match_fill r - mktac (PrepFill n ns) = prep_fill n ns - mktac CompleteFill = complete_fill - mktac Regret = regret - mktac Solve = solve - mktac (StartUnify n) = start_unify n - mktac Compute = compute - mktac Simplify = Core.ProofState.simplify - mktac HNF_Compute = hnf_compute - mktac (Intro n) = intro n - mktac (IntroTy ty n) = introTy ty n - mktac (Forall n t) = forall n t - mktac (LetBind n t v) = letbind n t v - mktac (ExpandLet n b) = expandLet n b - mktac (Rewrite t) = rewrite t - mktac (Equiv t) = equiv t - mktac (PatVar n) = patvar n - mktac (PatBind n) = patbind n - mktac (CheckIn r) = check_in r - mktac (EvalIn r) = eval_in r - mktac (Focus n) = focus n - mktac (Defer n) = defer n - mktac (DeferType n t a) = deferType n t a - mktac (Instance n) = instanceArg n - mktac (SetInjective n) = setinj n - mktac (MoveLast n) = movelast n diff --git a/src/Core/TT.hs b/src/Core/TT.hs deleted file mode 100644 --- a/src/Core/TT.hs +++ /dev/null @@ -1,1061 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor #-} - -{-| TT is the core language of Idris. The language has: - - * Full dependent types - - * A hierarchy of universes, with cumulativity: Type : Type1, Type1 : Type2, ... - - * Pattern matching letrec binding - - * (primitive types defined externally) - - Some technical stuff: - - * Typechecker is kept as simple as possible - no unification, just a checker for incomplete terms. - - * We have a simple collection of tactics which we use to elaborate source - programs with implicit syntax into fully explicit terms. --} - -module Core.TT where - -import Control.Monad.State -import Control.Monad.Trans.Error (Error(..)) -import Debug.Trace -import qualified Data.Map as Map -import Data.Char -import Data.List -import Data.Vector.Unboxed (Vector) -import qualified Data.Vector.Unboxed as V -import qualified Data.Binary as B -import Data.Binary hiding (get, put) -import Foreign.Storable (sizeOf) - -import Util.Pretty hiding (Str) - -data Option = TTypeInTType - | CheckConv - deriving Eq - --- | Source location. These are typically produced by the parser 'Idris.Parser.getFC' -data FC = FC { fc_fname :: String, -- ^ Filename - fc_line :: Int, -- ^ Line number - fc_column :: Int -- ^ Column number - } - --- | Ignore source location equality (so deriving classes do not compare FCs) -instance Eq FC where - _ == _ = True - --- | FC with equality -newtype FC' = FC' { unwrapFC :: FC } - -instance Eq FC' where - FC' fc == FC' fc' = fcEq fc fc' - where fcEq (FC n l c) (FC n' l' c') = n == n' && l == l' && c == c' - --- | Empty source location -emptyFC :: FC -emptyFC = fileFC "" - --- | Source location with file only -fileFC :: String -> FC -fileFC s = FC s 0 0 - -{-! -deriving instance Binary FC -deriving instance NFData FC -!-} - -instance Sized FC where - size (FC f l c) = 1 + length f - -instance Show FC where - show (FC f l c) = f ++ ":" ++ show l ++ ":" ++ show c - -data Err = Msg String - | InternalMsg String - | CantUnify Bool Term Term Err [(Name, Type)] Int - -- Int is 'score' - how much we did unify - -- Bool indicates recoverability, True indicates more info may make - -- unification succeed - | InfiniteUnify Name Term [(Name, Type)] - | CantConvert Term Term [(Name, Type)] - | UnifyScope Name Name Term [(Name, Type)] - | CantInferType String - | NonFunctionType Term Term - | TooManyArguments Name - | CantIntroduce Term - | NoSuchVariable Name - | NoTypeDecl Name - | NotInjective Term Term Term - | CantResolve Term - | CantResolveAlts [String] - | IncompleteTerm Term - | UniverseError - | ProgramLineComment - | Inaccessible Name - | NonCollapsiblePostulate Name - | AlreadyDefined Name - | ProofSearchFail Err - | NoRewriting Term - | At FC Err - | Elaborating String Name Err - | ProviderError String - | LoadingFailed String Err - deriving Eq -{-! -deriving instance NFData Err -!-} - -instance Sized Err where - size (Msg msg) = length msg - size (InternalMsg msg) = length msg - size (CantUnify _ left right err _ score) = size left + size right + size err - size (InfiniteUnify _ right _) = size right - size (CantConvert left right _) = size left + size right - size (UnifyScope _ _ right _) = size right - size (NoSuchVariable name) = size name - 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 (Elaborating _ n err) = size err - size (ProviderError msg) = length msg - size (LoadingFailed fn e) = 1 + length fn + size e - size _ = 1 - -score :: Err -> Int -score (CantUnify _ _ _ m _ s) = s + score m -score (CantResolve _) = 20 -score (NoSuchVariable _) = 1000 -score (ProofSearchFail _) = 10000 -score (InternalMsg _) = -1 -score _ = 0 - -instance Show Err where - show (Msg s) = s - show (InternalMsg s) = "Internal error: " ++ show s - 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 (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: " ++ show e - show _ = "Error" - -instance Pretty Err where - pretty (Msg m) = text m - pretty (CantUnify _ l r e _ i) = - if size l + size r > breakingSize then - text "Cannot unify" <+> colon $$ - nest nestingSize (pretty l <+> text "and" <+> pretty r) $$ - nest nestingSize (text "where" <+> pretty e <+> text "with" <+> (text . show $ i)) - 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 err@(LoadingFailed _ _) = text (show err) - pretty _ = text "Error" - -instance Error Err where - strMsg = Msg - -data TC a = OK a - | Error Err - deriving (Eq, Functor) - -instance Pretty a => Pretty (TC a) where - pretty (OK ok) = pretty ok - pretty (Error err) = - if size err > breakingSize then - text "Error" <+> colon $$ (nest nestingSize $ pretty err) - else - text "Error" <+> colon <+> pretty err - -instance Show a => Show (TC a) where - show (OK x) = show x - show (Error str) = "Error: " ++ show str - --- at some point, this instance should also carry type checking options --- (e.g. Type:Type) - -instance Monad TC where - return = OK - x >>= k = case x of - OK v -> k v - Error e -> Error e - fail e = Error (InternalMsg e) - -tfail :: Err -> TC a -tfail e = Error e - -trun :: FC -> TC a -> TC a -trun fc (OK a) = OK a -trun fc (Error e) = Error (At fc e) - -instance MonadPlus TC where - mzero = fail "Unknown error" - (OK x) `mplus` _ = OK x - _ `mplus` (OK y) = OK y - err `mplus` _ = err - -discard :: Monad m => m a -> m () -discard f = f >> return () - -showSep :: String -> [String] -> String -showSep sep [] = "" -showSep sep [x] = x -showSep sep (x:xs) = x ++ sep ++ showSep sep xs - -pmap f (x, y) = (f x, f y) - -traceWhen True msg a = trace msg a -traceWhen False _ a = a - --- RAW TERMS ---------------------------------------------------------------- - --- | Names are hierarchies of strings, describing scope (so no danger of --- duplicate names, but need to be careful on lookup). -data Name = UN String -- ^ User-provided name - | NS Name [String] -- ^ Root, namespaces - | MN Int String -- ^ Machine chosen names - | NErased -- ^ Name of somethng which is never used in scope - | SN SpecialName -- ^ Decorated function names - deriving (Eq, Ord) -{-! -deriving instance Binary Name -deriving instance NFData Name -!-} - -data SpecialName = WhereN Int Name Name - | InstanceN Name [String] - | ParentN Name String - | MethodN Name - | CaseN Name - | ElimN Name - deriving (Eq, Ord) -{-! -deriving instance Binary SpecialName -deriving instance NFData SpecialName -!-} - -instance Sized Name where - size (UN n) = 1 - size (NS n els) = 1 + length els - size (MN i n) = 1 - size _ = 1 - -instance Pretty Name where - pretty (UN n) = text n - pretty (NS n s) = pretty n - pretty (MN i s) = lbrace <+> text s <+> (text . show $ i) <+> rbrace - pretty (SN s) = text (show s) - -instance Show Name where - show (UN n) = n - show (NS n s) = showSep "." (reverse s) ++ "." ++ show n - show (MN _ "underscore") = "_" - show (MN i s) = "{" ++ s ++ show i ++ "}" - show (SN s) = show s - show NErased = "_" - -instance Show SpecialName where - show (WhereN i p c) = show p ++ ", " ++ show c - show (InstanceN cl inst) = showSep ", " inst ++ " instance of " ++ show cl - show (MethodN m) = "method " ++ show m - show (ParentN p c) = show p ++ "#" ++ c - show (CaseN n) = "case block in " ++ show n - show (ElimN n) = "<<" ++ show n ++ " eliminator>>" - --- Show a name in a way decorated for code generation, not human reading -showCG :: Name -> String -showCG (UN n) = n -showCG (NS n s) = showSep "." (reverse s) ++ "." ++ showCG n -showCG (MN _ "underscore") = "_" -showCG (MN i s) = "{" ++ s ++ show i ++ "}" -showCG (SN s) = showCG' s - where showCG' (WhereN i p c) = showCG p ++ ":" ++ showCG c ++ ":" ++ show i - showCG' (InstanceN cl inst) = '@':showCG cl ++ '$':showSep ":" inst - showCG' (MethodN m) = '!':showCG m - showCG' (ParentN p c) = showCG p ++ "#" ++ show c - showCG' (CaseN c) = showCG c ++ "_case" -showCG NErased = "_" - - --- |Contexts allow us to map names to things. A root name maps to a collection --- of things in different namespaces with that name. -type Ctxt a = Map.Map Name (Map.Map Name a) -emptyContext = Map.empty - -tcname (UN ('@':_)) = True -tcname (NS n _) = tcname n -tcname (SN (InstanceN _ _)) = True -tcname (SN (MethodN _)) = True -tcname (SN (ParentN _ _)) = True -tcname _ = False - -implicitable (NS n _) = implicitable n -implicitable (UN (x:xs)) = isLower x -implicitable (MN _ _) = True -implicitable _ = False - -nsroot (NS n _) = n -nsroot n = n - -addDef :: Name -> a -> Ctxt a -> Ctxt a -addDef n v ctxt = case Map.lookup (nsroot n) ctxt of - Nothing -> Map.insert (nsroot n) - (Map.insert n v Map.empty) ctxt - Just xs -> Map.insert (nsroot n) - (Map.insert n v xs) ctxt - -{-| Look up a name in the context, given an optional namespace. - The name (n) may itself have a (partial) namespace given. - - Rules for resolution: - - - if an explicit namespace is given, return the names which match it. If none - match, return all names. - - - if the name has has explicit namespace given, return the names which match it - and ignore the given namespace. - - - otherwise, return all names. - --} - -lookupCtxtName :: Name -> Ctxt a -> [(Name, a)] -lookupCtxtName n ctxt = case Map.lookup (nsroot n) ctxt of - Just xs -> filterNS (Map.toList xs) - Nothing -> [] - where - filterNS [] = [] - filterNS ((found, v) : xs) - | nsmatch n found = (found, v) : filterNS xs - | otherwise = filterNS xs - - nsmatch (NS n ns) (NS p ps) = ns `isPrefixOf` ps - nsmatch (NS _ _) _ = False - nsmatch looking found = True - -lookupCtxt :: Name -> Ctxt a -> [a] -lookupCtxt n ctxt = map snd (lookupCtxtName n ctxt) - -lookupCtxtExact :: Name -> Ctxt a -> [a] -lookupCtxtExact n ctxt = [ v | (nm, v) <- lookupCtxtName n ctxt, nm == n] - -updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a -updateDef n f ctxt - = let ds = lookupCtxtName n ctxt in - foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds - -toAlist :: Ctxt a -> [(Name, a)] -toAlist ctxt = let allns = map snd (Map.toList ctxt) in - concat (map (Map.toList) allns) - -addAlist :: Show a => [(Name, a)] -> Ctxt a -> Ctxt a -addAlist [] ctxt = ctxt -addAlist ((n, tm) : ds) ctxt = addDef n tm (addAlist ds ctxt) - -data NativeTy = IT8 | IT16 | IT32 | IT64 - deriving (Show, Eq, Ord, Enum) - -instance Pretty NativeTy where - pretty IT8 = text "Bits8" - pretty IT16 = text "Bits16" - pretty IT32 = text "Bits32" - pretty IT64 = text "Bits64" - -data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar - | ITVec NativeTy Int - deriving (Show, Eq, Ord) - -data ArithTy = ATInt IntTy | ATFloat -- TODO: Float vectors - deriving (Show, Eq, Ord) -{-! -deriving instance NFData IntTy -deriving instance NFData NativeTy -deriving instance NFData ArithTy -!-} - -instance Pretty ArithTy where - pretty (ATInt ITNative) = text "Int" - pretty (ATInt ITBig) = text "BigInt" - pretty (ATInt ITChar) = text "Char" - pretty (ATInt (ITFixed n)) = pretty n - pretty (ATInt (ITVec e c)) = pretty e <> text "x" <> (text . show $ c) - pretty ATFloat = text "Float" - -nativeTyWidth :: NativeTy -> Int -nativeTyWidth IT8 = 8 -nativeTyWidth IT16 = 16 -nativeTyWidth IT32 = 32 -nativeTyWidth IT64 = 64 - -{-# DEPRECATED intTyWidth "Non-total function, use nativeTyWidth and appropriate casing" #-} -intTyWidth :: IntTy -> Int -intTyWidth (ITFixed n) = nativeTyWidth n -intTyWidth ITNative = 8 * sizeOf (0 :: Int) -intTyWidth ITChar = error "IRTS.Lang.intTyWidth: Characters have platform and backend dependent width" -intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width" - -data Const = I Int | BI Integer | Fl Double | Ch Char | Str String - | B8 Word8 | B16 Word16 | B32 Word32 | B64 Word64 - | B8V (Vector Word8) | B16V (Vector Word16) - | B32V (Vector Word32) | B64V (Vector Word64) - | AType ArithTy | StrType - | PtrType | VoidType | Forgot - deriving (Eq, Ord) -{-! -deriving instance Binary Const -deriving instance NFData Const -!-} - -instance Sized Const where - size _ = 1 - -instance Pretty Const where - pretty (I i) = text . show $ i - pretty (BI i) = text . show $ i - pretty (Fl f) = text . show $ f - pretty (Ch c) = text . show $ c - pretty (Str s) = text s - pretty (AType a) = pretty a - pretty StrType = text "String" - pretty PtrType = text "Ptr" - pretty VoidType = text "Void" - pretty Forgot = text "Forgot" - pretty (B8 w) = text . show $ w - pretty (B16 w) = text . show $ w - pretty (B32 w) = text . show $ w - pretty (B64 w) = text . show $ w - -data Raw = Var Name - | RBind Name (Binder Raw) Raw - | RApp Raw Raw - | RType - | RForce Raw - | RConstant Const - deriving (Show, Eq) - -instance Sized Raw where - size (Var name) = 1 - size (RBind name bind right) = 1 + size bind + size right - size (RApp left right) = 1 + size left + size right - size RType = 1 - size (RForce raw) = 1 + size raw - size (RConstant const) = size const - -instance Pretty Raw where - pretty = text . show - -{-! -deriving instance Binary Raw -deriving instance NFData Raw -!-} - --- | All binding forms are represented in a unform fashion. -data Binder b = Lam { binderTy :: b {-^ type annotation for bound variable-}} - | Pi { binderTy :: b } - | Let { binderTy :: b, - binderVal :: b {-^ value for bound variable-}} - | NLet { binderTy :: b, - binderVal :: b } - | Hole { binderTy :: b} - | GHole { envlen :: Int, - binderTy :: b} - | Guess { binderTy :: b, - binderVal :: b } - | PVar { binderTy :: b } - | PVTy { binderTy :: b } - deriving (Show, Eq, Ord, Functor) -{-! -deriving instance Binary Binder -deriving instance NFData Binder -!-} - -instance Sized a => Sized (Binder a) where - size (Lam ty) = 1 + size ty - size (Pi ty) = 1 + size ty - size (Let ty val) = 1 + size ty + size val - size (NLet ty val) = 1 + size ty + size val - size (Hole ty) = 1 + size ty - size (GHole _ ty) = 1 + size ty - size (Guess ty val) = 1 + size ty + size val - size (PVar ty) = 1 + size ty - size (PVTy ty) = 1 + size ty - -fmapMB :: Monad m => (a -> m b) -> Binder a -> m (Binder b) -fmapMB f (Let t v) = liftM2 Let (f t) (f v) -fmapMB f (NLet t v) = liftM2 NLet (f t) (f v) -fmapMB f (Guess t v) = liftM2 Guess (f t) (f v) -fmapMB f (Lam t) = liftM Lam (f t) -fmapMB f (Pi t) = liftM Pi (f t) -fmapMB f (Hole t) = liftM Hole (f t) -fmapMB f (GHole i t) = liftM (GHole i) (f t) -fmapMB f (PVar t) = liftM PVar (f t) -fmapMB f (PVTy t) = liftM PVTy (f t) - -raw_apply :: Raw -> [Raw] -> Raw -raw_apply f [] = f -raw_apply f (a : as) = raw_apply (RApp f a) as - -raw_unapply :: Raw -> (Raw, [Raw]) -raw_unapply t = ua [] t where - ua args (RApp f a) = ua (a:args) f - ua args t = (t, args) - -data RawFun = RawFun { rtype :: Raw, - rval :: Raw - } - deriving Show - -data RawDatatype = RDatatype Name Raw [(Name, Raw)] - deriving Show - -data RDef = RFunction RawFun - | RConst Raw - | RData RawDatatype - deriving Show - -type RProgram = [(Name, RDef)] - --- WELL TYPED TERMS --------------------------------------------------------- - --- | Universe expressions for universe checking -data UExp = UVar Int -- ^ universe variable - | UVal Int -- ^ explicit universe level - deriving (Eq, Ord) -{-! -deriving instance NFData UExp -!-} - -instance Sized UExp where - size _ = 1 - --- We assume that universe levels have been checked, so anything external --- can just have the same universe variable and we won't get any new --- cycles. - -instance Binary UExp where - put x = return () - get = return (UVar (-1)) - -instance Show UExp where - show (UVar x) | x < 26 = [toEnum (x + fromEnum 'a')] - | otherwise = toEnum ((x `mod` 26) + fromEnum 'a') : show (x `div` 26) - show (UVal x) = show x --- show (UMax l r) = "max(" ++ show l ++ ", " ++ show r ++")" - --- | Universe constraints -data UConstraint = ULT UExp UExp -- ^ Strictly less than - | ULE UExp UExp -- ^ Less than or equal to - deriving Eq - -instance Show UConstraint where - show (ULT x y) = show x ++ " < " ++ show y - show (ULE x y) = show x ++ " <= " ++ show y - -type UCs = (Int, [UConstraint]) - -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 -deriving instance NFData NameType -!-} - -instance Sized NameType where - size _ = 1 - -instance Pretty NameType where - pretty = text . show - -instance Eq NameType where - Bound == Bound = True - Ref == Ref = True - DCon _ a == DCon _ b = (a == b) -- ignore tag - TCon _ a == TCon _ b = (a == b) -- ignore tag - _ == _ = False - --- | Terms in the core language -data TT n = P NameType n (TT n) -- ^ named references - | V Int -- ^ a resolved de Bruijn-indexed variable - | Bind n (Binder (TT n)) (TT n) -- ^ a binding - | App (TT n) (TT n) -- ^ function, function type, arg - | Constant Const -- ^ constant - | Proj (TT n) Int -- ^ argument projection; runtime only - -- (-1) is a special case for 'subtract one from BI' - | Erased -- ^ an erased term - | Impossible -- ^ special case for totality checking - | TType UExp -- ^ the type of types at some level - deriving (Ord, Functor) -{-! -deriving instance Binary TT -deriving instance NFData TT -!-} - -class TermSize a where - termsize :: Name -> a -> Int - -instance TermSize a => TermSize [a] where - termsize n [] = 0 - termsize n (x : xs) = termsize n x + termsize n xs - -instance TermSize (TT Name) where - termsize n (P _ x _) - | x == n = 1000000 -- recursive => really big - | otherwise = 1 - termsize n (V _) = 1 - termsize n (Bind n' (Let t v) sc) - = let rn = if n == n' then MN 0 "noname" else n in - termsize rn v + termsize rn sc - termsize n (Bind n' b sc) - = let rn = if n == n' then MN 0 "noname" else n in - termsize rn sc - termsize n (App f a) = termsize n f + termsize n a - termsize n (Proj t i) = termsize n t - termsize n _ = 1 - -instance Sized a => Sized (TT a) where - size (P name n trm) = 1 + size name + size n + size trm - size (V v) = 1 - size (Bind nm binder bdy) = 1 + size nm + size binder + size bdy - size (App l r) = 1 + size l + size r - size (Constant c) = size c - size Erased = 1 - size (TType u) = 1 + size u - -instance Pretty a => Pretty (TT a) where - pretty _ = text "test" - -type EnvTT n = [(n, Binder (TT n))] - -data Datatype n = Data { d_typename :: n, - d_typetag :: Int, - d_type :: (TT n), - d_cons :: [(n, TT n)] } - deriving (Show, Functor, Eq) - -instance Eq n => Eq (TT n) where - (==) (P xt x _) (P yt y _) = x == y - (==) (V x) (V y) = x == y - (==) (Bind _ xb xs) (Bind _ yb ys) = xb == yb && xs == ys - (==) (App fx ax) (App fy ay) = fx == fy && ax == ay - (==) (TType _) (TType _) = True -- deal with constraints later - (==) (Constant x) (Constant y) = x == y - (==) (Proj x i) (Proj y j) = x == y && i == j - (==) Erased _ = True - (==) _ Erased = True - (==) _ _ = False - --- * A few handy operations on well typed terms: - --- | A term is injective iff it is a data constructor, type constructor, --- constant, the type Type, pi-binding, or an application of an injective --- term. -isInjective :: TT n -> Bool -isInjective (P (DCon _ _) _ _) = True -isInjective (P (TCon _ _) _ _) = True -isInjective (Constant _) = True -isInjective (TType x) = True -isInjective (Bind _ (Pi _) sc) = True -isInjective (App f a) = isInjective f -isInjective _ = False - --- | Count the number of instances of a de Bruijn index in a term -vinstances :: Int -> TT n -> Int -vinstances i (V x) | i == x = 1 -vinstances i (App f a) = vinstances i f + vinstances i a -vinstances i (Bind x b sc) = instancesB b + vinstances (i + 1) sc - where instancesB (Let t v) = vinstances i v - instancesB _ = 0 -vinstances i t = 0 - -instantiate :: TT n -> TT n -> TT n -instantiate e = subst 0 where - subst i (V x) | i == x = e - subst i (Bind x b sc) = Bind x (fmap (subst i) b) (subst (i+1) sc) - subst i (App f a) = App (subst i f) (subst i a) - subst i (Proj x idx) = Proj (subst i x) idx - subst i t = t - -substV :: TT n -> TT n -> TT n -substV x tm = dropV 0 (instantiate x tm) where - dropV i (V x) | x > i = V (x - 1) - | otherwise = V x - dropV i (Bind x b sc) = Bind x (fmap (dropV i) b) (dropV (i+1) sc) - dropV i (App f a) = App (dropV i f) (dropV i a) - dropV i (Proj x idx) = Proj (dropV i x) idx - dropV i t = t - -explicitNames :: TT n -> TT n -explicitNames (Bind x b sc) = let b' = fmap explicitNames b in - Bind x b' - (explicitNames (instantiate - (P Bound x (binderTy b')) sc)) -explicitNames (App f a) = App (explicitNames f) (explicitNames a) -explicitNames (Proj x idx) = Proj (explicitNames x) idx -explicitNames t = t - -pToV :: Eq n => n -> TT n -> TT n -pToV n = pToV' n 0 -pToV' n i (P _ x _) | n == x = V i -pToV' n i (Bind x b sc) --- We can assume the inner scope has been pToVed already, so continue to --- resolve names from the *outer* scope which may happen to have the same id. - | n == x = Bind x (fmap (pToV' n i) b) sc - | otherwise = Bind x (fmap (pToV' n i) b) (pToV' n (i+1) sc) -pToV' n i (App f a) = App (pToV' n i f) (pToV' n i a) -pToV' n i (Proj t idx) = Proj (pToV' n i t) idx -pToV' n i t = t - --- increase de Bruijn indices, as if a binder has been added -addBinder :: TT n -> TT n -addBinder t = ab 0 t - where - ab top (V i) | i >= top = V (i + 1) - | otherwise = V i - ab top (Bind x b sc) = Bind x (fmap (ab top) b) (ab (top + 1) sc) - ab top (App f a) = App (ab top f) (ab top a) - ab top (Proj t idx) = Proj (ab top t) idx - ab top t = t - --- | Convert several names. First in the list comes out as V 0 -pToVs :: Eq n => [n] -> TT n -> TT n -pToVs ns tm = pToVs' ns tm 0 where - pToVs' [] tm i = tm - pToVs' (n:ns) tm i = pToV' n i (pToVs' ns tm (i+1)) - -vToP :: TT n -> TT n -vToP = vToP' [] where - vToP' env (V i) = let (n, b) = (env !! i) in - P Bound n (binderTy b) - vToP' env (Bind n b sc) = let b' = fmap (vToP' env) b in - Bind n b' (vToP' ((n, b'):env) sc) - vToP' env (App f a) = App (vToP' env f) (vToP' env a) - vToP' env t = t - -finalise :: Eq n => TT n -> TT n -finalise (Bind x b sc) = Bind x (fmap finalise b) (pToV x (finalise sc)) -finalise (App f a) = App (finalise f) (finalise a) -finalise t = t - -subst :: Eq n => n -> TT n -> TT n -> TT n -subst n v tm = instantiate v (pToV n tm) - -substNames :: Eq n => [(n, TT n)] -> TT n -> TT n -substNames [] t = t -substNames ((n, tm) : xs) t = subst n tm (substNames xs t) - -substTerm :: Eq n => TT n -> TT n -> TT n -> TT n -substTerm old new = st where - st t | t == old = new - st (App f a) = App (st f) (st a) - st (Bind x b sc) = Bind x (fmap st b) (st sc) - st t = t - --- Returns true if V 0 and bound name n do not occur in the term - -noOccurrence :: Eq n => n -> TT n -> Bool -noOccurrence n t = no' 0 t - where - no' i (V x) = not (i == x) - no' i (P Bound x _) = not (n == x) - no' i (Bind n b sc) = noB' i b && no' (i+1) sc - where noB' i (Let t v) = no' i t && no' i v - noB' i (Guess t v) = no' i t && no' i v - noB' i b = no' i (binderTy b) - no' i (App f a) = no' i f && no' i a - no' i (Proj x _) = no' i x - no' i _ = True - --- | Returns all names used free in the term -freeNames :: Eq n => TT n -> [n] -freeNames (P _ n _) = [n] -freeNames (Bind n (Let t v) sc) = nub $ freeNames v ++ (freeNames sc \\ [n]) - ++ freeNames t -freeNames (Bind n b sc) = nub $ freeNames (binderTy b) ++ (freeNames sc \\ [n]) -freeNames (App f a) = nub $ freeNames f ++ freeNames a -freeNames (Proj x i) = nub $ freeNames x -freeNames _ = [] - --- | Return the arity of a (normalised) type -arity :: TT n -> Int -arity (Bind n (Pi t) sc) = 1 + arity sc -arity _ = 0 - --- | Deconstruct an application; returns the function and a list of arguments -unApply :: TT n -> (TT n, [TT n]) -unApply t = ua [] t where - ua args (App f a) = ua (a:args) f - ua args t = (t, args) - -mkApp :: TT n -> [TT n] -> TT n -mkApp f [] = f -mkApp f (a:as) = mkApp (App f a) as - -forget :: TT Name -> Raw -forget tm = fe [] tm - where - fe env (P _ n _) = Var n - fe env (V i) = Var (env !! i) - fe env (Bind n b sc) = RBind n (fmap (fe env) b) - (fe (n:env) sc) - fe env (App f a) = RApp (fe env f) (fe env a) - fe env (Constant c) - = RConstant c - fe env (TType i) = RType - fe env Erased = RConstant Forgot - -bindAll :: [(n, Binder (TT n))] -> TT n -> TT n -bindAll [] t =t -bindAll ((n, b) : bs) t = Bind n b (bindAll bs t) - -bindTyArgs :: (TT n -> Binder (TT n)) -> [(n, TT n)] -> TT n -> TT n -bindTyArgs b xs = bindAll (map (\ (n, ty) -> (n, b ty)) xs) - -getArgTys :: TT n -> [(n, TT n)] -getArgTys (Bind n (Pi t) sc) = (n, t) : getArgTys sc -getArgTys _ = [] - -getRetTy :: TT n -> TT n -getRetTy (Bind n (PVar _) sc) = getRetTy sc -getRetTy (Bind n (PVTy _) sc) = getRetTy sc -getRetTy (Bind n (Pi _) sc) = getRetTy sc -getRetTy sc = sc - -uniqueNameFrom :: [Name] -> [Name] -> Name -uniqueNameFrom (s : supply) hs - | s `elem` hs = uniqueNameFrom supply hs - | otherwise = s - -uniqueName :: Name -> [Name] -> Name -uniqueName n hs | n `elem` hs = uniqueName (nextName n) hs - | otherwise = n - -uniqueBinders :: [Name] -> TT Name -> TT Name -uniqueBinders ns (Bind n b sc) - = let n' = uniqueName n ns in - Bind n' (fmap (uniqueBinders (n':ns)) b) (uniqueBinders ns sc) -uniqueBinders ns (App f a) = App (uniqueBinders ns f) (uniqueBinders ns a) -uniqueBinders ns t = t - - -nextName (NS x s) = NS (nextName x) s -nextName (MN i n) = MN (i+1) n -nextName (UN x) = let (num', nm') = span isDigit (reverse x) - nm = reverse nm' - num = readN (reverse num') in - UN (nm ++ show (num+1)) - where - readN "" = 0 - readN x = read x -nextName (SN x) = SN (nextName' x) - where - nextName' (WhereN i f x) = WhereN i f (nextName x) - nextName' (CaseN n) = CaseN (nextName n) - nextName' (MethodN n) = MethodN (nextName n) - -type Term = TT Name -type Type = Term - -type Env = EnvTT Name - --- an environment with de Bruijn indices 'normalised' so that they all refer to --- this environment - -newtype WkEnvTT n = Wk (EnvTT n) -type WkEnv = WkEnvTT Name - -instance (Eq n, Show n) => Show (TT n) where - show t = showEnv [] t - -itBitsName IT8 = "Bits8" -itBitsName IT16 = "Bits16" -itBitsName IT32 = "Bits32" -itBitsName IT64 = "Bits64" - -instance Show Const where - show (I i) = show i - show (BI i) = show i - show (Fl f) = show f - show (Ch c) = show c - show (Str s) = show s - show (B8 x) = show x - show (B16 x) = show x - show (B32 x) = show x - show (B64 x) = show x - show (B8V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" - show (B16V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" - show (B32V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" - show (B64V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" - show (AType ATFloat) = "Float" - show (AType (ATInt ITBig)) = "Integer" - show (AType (ATInt ITNative)) = "Int" - show (AType (ATInt ITChar)) = "Char" - show (AType (ATInt (ITFixed it))) = itBitsName it - show (AType (ATInt (ITVec it c))) = itBitsName it ++ "x" ++ show c - show StrType = "String" - show PtrType = "Ptr" - show VoidType = "Void" - -showEnv env t = showEnv' env t False -showEnvDbg env t = showEnv' env t True - -prettyEnv env t = prettyEnv' env t False - where - prettyEnv' env t dbg = prettySe 10 env t dbg - - bracket outer inner p - | inner > outer = lparen <> p <> rparen - | otherwise = p - - prettySe p env (P nt n t) debug = - pretty n <+> - if debug then - lbrack <+> pretty nt <+> colon <+> prettySe 10 env t debug <+> rbrack - else - empty - prettySe p env (V i) debug - | i < length env = - if debug then - text . show . fst $ env!!i - else - lbrack <+> text (show i) <+> rbrack - | otherwise = text "unbound" <+> text (show i) <+> text "!" - prettySe p env (Bind n b@(Pi t) sc) debug - | noOccurrence n sc && not debug = - bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug - prettySe p env (Bind n b sc) debug = - bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug - prettySe p env (App f a) debug = - bracket p 1 $ prettySe 1 env f debug <+> prettySe 0 env a debug - prettySe p env (Proj x i) debug = - prettySe 1 env x debug <+> text ("!" ++ show i) - prettySe p env (Constant c) debug = pretty c - prettySe p env Erased debug = text "[_]" - prettySe p env (TType i) debug = text "Type" <+> (text . show $ i) - - prettySb env n (Lam t) = prettyB env "λ" "=>" n t - prettySb env n (Hole t) = prettyB env "?defer" "." n t - prettySb env n (Pi t) = prettyB env "(" ") ->" n t - prettySb env n (PVar t) = prettyB env "pat" "." n t - prettySb env n (PVTy t) = prettyB env "pty" "." n t - prettySb env n (Let t v) = prettyBv env "let" "in" n t v - prettySb env n (Guess t v) = prettyBv env "??" "in" n t v - - prettyB env op sc n t debug = - text op <> pretty n <+> colon <+> prettySe 10 env t debug <> text sc - - prettyBv env op sc n t v debug = - text op <> pretty n <+> colon <+> prettySe 10 env t debug <+> text "=" <+> - prettySe 10 env v debug <> text sc - - -showEnv' env t dbg = se 10 env t where - se p env (P nt n t) = show n - ++ if dbg then "{" ++ show nt ++ " : " ++ se 10 env t ++ "}" else "" - se p env (V i) | i < length env && i >= 0 - = (show $ fst $ env!!i) ++ - if dbg then "{" ++ show i ++ "}" else "" - | otherwise = "!!V " ++ show i ++ "!!" - se p env (Bind n b@(Pi t) sc) - | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ " -> " ++ se 10 ((n,b):env) sc - se p env (Bind n b sc) = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc - se p env (App f a) = bracket p 1 $ se 1 env f ++ " " ++ se 0 env a - se p env (Proj x i) = se 1 env x ++ "!" ++ show i - se p env (Constant c) = show c - se p env Erased = "[__]" - se p env Impossible = "[impossible]" - se p env (TType i) = "Type " ++ show i - - sb env n (Lam t) = showb env "\\ " " => " n t - sb env n (Hole t) = showb env "? " ". " n t - sb env n (GHole i t) = showb env "?defer " ". " n t - sb env n (Pi t) = showb env "(" ") -> " n t - sb env n (PVar t) = showb env "pat " ". " n t - sb env n (PVTy t) = showb env "pty " ". " n t - sb env n (Let t v) = showbv env "let " " in " n t v - sb env n (Guess t v) = showbv env "?? " " in " n t v - - showb env op sc n t = op ++ show n ++ " : " ++ se 10 env t ++ sc - showbv env op sc n t v = op ++ show n ++ " : " ++ se 10 env t ++ " = " ++ - se 10 env v ++ sc - - bracket outer inner str | inner > outer = "(" ++ str ++ ")" - | otherwise = str - --- | Check whether a term has any holes in it - impure if so -pureTerm :: TT Name -> Bool -pureTerm (App f a) = pureTerm f && pureTerm a -pureTerm (Bind n b sc) = notClassName n && pureBinder b && pureTerm sc where - pureBinder (Hole _) = False - pureBinder (Guess _ _) = False - pureBinder (Let t v) = pureTerm t && pureTerm v - pureBinder t = pureTerm (binderTy t) - - notClassName (MN _ "class") = False - notClassName _ = True - -pureTerm _ = True - --- | Weaken a term by adding i to each de Bruijn index (i.e. lift it over i bindings) -weakenTm :: Int -> TT n -> TT n -weakenTm i t = wk i 0 t - where wk i min (V x) | x >= min = V (i + x) - wk i m (App f a) = App (wk i m f) (wk i m a) - wk i m (Bind x b sc) = Bind x (wkb i m b) (wk i (m + 1) sc) - wk i m t = t - wkb i m t = fmap (wk i m) t - --- | Weaken an environment so that all the de Bruijn indices are correct according --- to the latest bound variable - -weakenEnv :: EnvTT n -> EnvTT n -weakenEnv env = wk (length env - 1) env - where wk i [] = [] - wk i ((n, b) : bs) = (n, weakenTmB i b) : wk (i - 1) bs - weakenTmB i (Let t v) = Let (weakenTm i t) (weakenTm i v) - weakenTmB i (Guess t v) = Guess (weakenTm i t) (weakenTm i v) - weakenTmB i t = t { binderTy = weakenTm i (binderTy t) } - -weakenTmEnv :: Int -> EnvTT n -> EnvTT n -weakenTmEnv i = map (\ (n, b) -> (n, fmap (weakenTm i) b)) - -orderPats :: Term -> Term -orderPats tm = op [] tm - where - op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc - op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc - op ps sc = bindAll (sortP ps) sc - - sortP ps = pick [] (reverse ps) - - namesIn (P _ n _) = [n] - namesIn (Bind n b t) = nub $ nb b ++ (namesIn t \\ [n]) - where nb (Let t v) = nub (namesIn t) ++ nub (namesIn v) - nb (Guess t v) = nub (namesIn t) ++ nub (namesIn v) - nb t = namesIn (binderTy t) - namesIn (App f a) = nub (namesIn f ++ namesIn a) - namesIn _ = [] - - pick acc [] = reverse acc - pick acc ((n, t) : ps) = pick (insert n t acc) ps - - insert n t [] = [(n, t)] - insert n t ((n',t') : ps) - | n `elem` (namesIn (binderTy t') ++ - concatMap namesIn (map (binderTy . snd) ps)) - = (n', t') : insert n t ps - | otherwise = (n,t):(n',t'):ps - diff --git a/src/Core/Typecheck.hs b/src/Core/Typecheck.hs deleted file mode 100644 --- a/src/Core/Typecheck.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, - PatternGuards #-} - -module Core.Typecheck where - -import Control.Monad.State -import Debug.Trace -import qualified Data.Vector.Unboxed as V (length) - -import Core.TT -import Core.Evaluate - --- To check conversion, normalise each term wrt the current environment. --- Since we haven't converted everything to de Bruijn indices yet, we'll have to --- deal with alpha conversion - we do this by making each inner term de Bruijn --- indexed with 'finalise' - -convertsC :: Context -> Env -> Term -> Term -> StateT UCs TC () -convertsC ctxt env x y - = do c1 <- convEq ctxt x y - if c1 then return () - else - do c2 <- convEq ctxt (finalise (normalise ctxt env x)) - (finalise (normalise ctxt env y)) - if c2 then return () - else lift $ tfail (CantConvert - (finalise (normalise ctxt env x)) - (finalise (normalise ctxt env y)) (errEnv env)) - -converts :: Context -> Env -> Term -> Term -> TC () -converts ctxt env x y - = case convEq' ctxt x y of - OK True -> return () - _ -> case convEq' ctxt (finalise (normalise ctxt env x)) - (finalise (normalise ctxt env y)) of - OK True -> return () - _ -> tfail (CantConvert - (finalise (normalise ctxt env x)) - (finalise (normalise ctxt env y)) (errEnv env)) - -errEnv = map (\(x, b) -> (x, binderTy b)) - -isType :: Context -> Env -> Term -> TC () -isType ctxt env tm = isType' (normalise ctxt env tm) - where isType' (TType _) = return () - isType' tm = fail (showEnv env tm ++ " is not a TType") - -recheck :: Context -> Env -> Raw -> Term -> TC (Term, Type, UCs) -recheck ctxt env tm orig - = let v = next_tvar ctxt in - case runStateT (check' False ctxt env tm) (v, []) of -- holes banned - Error (IncompleteTerm _) -> Error $ IncompleteTerm orig - Error e -> Error e - OK ((tm, ty), constraints) -> - return (tm, ty, constraints) - -check :: Context -> Env -> Raw -> TC (Term, Type) -check ctxt env tm = evalStateT (check' True ctxt env tm) (0, []) -- Holes allowed - -check' :: Bool -> Context -> Env -> Raw -> StateT UCs TC (Term, Type) -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 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 - (av, aty) <- chk env a - let fty' = case uniqueBinders (map fst env) (finalise fty) of - ty@(Bind x (Pi s) t) -> ty - _ -> uniqueBinders (map fst env) - $ case hnf ctxt env fty of - ty@(Bind x (Pi s) t) -> ty - _ -> normalise ctxt env fty - case fty' of - Bind x (Pi s) t -> --- trace ("Converting " ++ show aty ++ " and " ++ show s ++ --- " from " ++ show fv ++ " : " ++ show fty) $ - do convertsC ctxt env aty s - -- let apty = normalise initContext env - -- (Bind x (Let aty av) t) - let apty = simplify initContext env - (Bind x (Let aty av) t) - return (App fv av, apty) - 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 - -- generated names, we'll be fine. - -- NOTE: now replaced with 'uniqueBinders' above - where renameBinders i (Bind x (Pi s) t) = Bind (MN i "binder") (Pi s) - (renameBinders (i+1) t) - renameBinders i sc = sc - chk env RType - | holes = return (TType (UVal 0), TType (UVal 0)) - | otherwise = do (v, cs) <- get - let c = ULT (UVar v) (UVar (v+1)) - put (v+2, (c:cs)) - return (TType (UVar v), TType (UVar (v+1))) - chk env (RConstant Forgot) = return (Erased, Erased) - chk env (RConstant c) = return (Constant c, constType c) - where constType (I _) = Constant (AType (ATInt ITNative)) - constType (BI _) = Constant (AType (ATInt ITBig)) - constType (Fl _) = Constant (AType ATFloat) - constType (Ch _) = Constant (AType (ATInt ITChar)) - constType (Str _) = Constant StrType - constType (B8 _) = Constant (AType (ATInt (ITFixed IT8))) - constType (B16 _) = Constant (AType (ATInt (ITFixed IT16))) - constType (B32 _) = Constant (AType (ATInt (ITFixed IT32))) - constType (B64 _) = Constant (AType (ATInt (ITFixed IT64))) - constType (B8V a) = Constant (AType (ATInt (ITVec IT8 (V.length a)))) - constType (B16V a) = Constant (AType (ATInt (ITVec IT16 (V.length a)))) - constType (B32V a) = Constant (AType (ATInt (ITVec IT32 (V.length a)))) - constType (B64V a) = Constant (AType (ATInt (ITVec IT64 (V.length a)))) - constType Forgot = Erased - constType _ = TType (UVal 0) - chk env (RForce t) = do (_, ty) <- chk env t - return (Erased, ty) - chk env (RBind n (Pi s) t) - = do (sv, st) <- chk env s - (tv, tt) <- chk ((n, Pi sv) : env) t - (v, cs) <- get - let TType su = normalise ctxt env st - let TType tu = normalise ctxt env tt - when (not holes) $ put (v+1, ULE su (UVar v):ULE tu (UVar v):cs) - return (Bind n (Pi (uniqueBinders (map fst env) sv)) - (pToV n tv), TType (UVar v)) - chk env (RBind n b sc) - = do b' <- checkBinder b - (scv, sct) <- chk ((n, b'):env) sc - discharge n b' (pToV n scv) (pToV n sct) - where checkBinder (Lam t) - = do (tv, tt) <- chk env t - let tv' = normalise ctxt env tv - let tt' = normalise ctxt env tt - lift $ isType ctxt env tt' - return (Lam tv) - checkBinder (Pi t) - = do (tv, tt) <- chk env t - let tv' = normalise ctxt env tv - let tt' = normalise ctxt env tt - lift $ isType ctxt env tt' - return (Pi tv) - checkBinder (Let t v) - = do (tv, tt) <- chk env t - (vv, vt) <- chk env v - let tv' = normalise ctxt env tv - let tt' = normalise ctxt env tt - convertsC ctxt env vt tv - lift $ isType ctxt env tt' - return (Let tv vv) - checkBinder (NLet t v) - = do (tv, tt) <- chk env t - (vv, vt) <- chk env v - let tv' = normalise ctxt env tv - let tt' = normalise ctxt env tt - convertsC ctxt env vt tv - lift $ isType ctxt env tt' - return (NLet tv vv) - checkBinder (Hole t) - | not holes = lift $ tfail (IncompleteTerm undefined) - | otherwise - = do (tv, tt) <- chk env t - let tv' = normalise ctxt env tv - let tt' = normalise ctxt env tt - lift $ isType ctxt env tt' - return (Hole tv) - checkBinder (GHole i t) - = do (tv, tt) <- chk env t - let tv' = normalise ctxt env tv - let tt' = normalise ctxt env tt - lift $ isType ctxt env tt' - return (GHole i tv) - checkBinder (Guess t v) - | not holes = lift $ tfail (IncompleteTerm undefined) - | otherwise - = do (tv, tt) <- chk env t - (vv, vt) <- chk env v - let tv' = normalise ctxt env tv - let tt' = normalise ctxt env tt - convertsC ctxt env vt tv - lift $ isType ctxt env tt' - return (Guess tv vv) - checkBinder (PVar t) - = do (tv, tt) <- chk env t - let tv' = normalise ctxt env tv - let tt' = normalise ctxt env tt - lift $ isType ctxt env tt' - -- Normalised version, for erasure purposes (it's easier - -- to tell if it's a collapsible variable) - return (PVar tv) - checkBinder (PVTy t) - = do (tv, tt) <- chk env t - let tv' = normalise ctxt env tv - let tt' = normalise ctxt env tt - lift $ isType ctxt env tt' - return (PVTy tv) - - discharge n (Lam t) scv sct - = return (Bind n (Lam t) scv, Bind n (Pi t) sct) - discharge n (Pi t) scv sct - = return (Bind n (Pi t) scv, sct) - discharge n (Let t v) scv sct - = return (Bind n (Let t v) scv, Bind n (Let t v) sct) - discharge n (NLet t v) scv sct - = return (Bind n (NLet t v) scv, Bind n (Let t v) sct) - discharge n (Hole t) scv sct - = return (Bind n (Hole t) scv, sct) - discharge n (GHole i t) scv sct - = return (Bind n (GHole i t) scv, sct) - discharge n (Guess t v) scv sct - = return (Bind n (Guess t v) scv, sct) - discharge n (PVar t) scv sct - = return (Bind n (PVar t) scv, Bind n (PVTy t) sct) - discharge n (PVTy t) scv sct - = return (Bind n (PVTy t) scv, sct) - - -checkProgram :: Context -> RProgram -> TC Context -checkProgram ctxt [] = return ctxt -checkProgram ctxt ((n, RConst t) : xs) - = do (t', tt') <- trace (show n) $ check ctxt [] t - isType ctxt [] tt' - 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 - isType ctxt [] tyt' - converts ctxt [] ty' valt' - checkProgram (addToCtxt n val' ty' ctxt) xs -checkProgram ctxt ((n, RData (RDatatype _ ty cons)) : xs) - = do (ty', tyt') <- trace (show n) $ check ctxt [] ty - isType ctxt [] tyt' - -- add the tycon temporarily so we can check constructors - let ctxt' = addDatatype (Data n 0 ty' []) ctxt - cons' <- mapM (checkCon ctxt') cons - checkProgram (addDatatype (Data n 0 ty' cons') ctxt) xs - where checkCon ctxt (n, cty) = do (cty', ctyt') <- check ctxt [] cty - return (n, cty') - - diff --git a/src/Core/Unify.hs b/src/Core/Unify.hs deleted file mode 100644 --- a/src/Core/Unify.hs +++ /dev/null @@ -1,526 +0,0 @@ -{-# LANGUAGE PatternGuards #-} - -module Core.Unify(match_unify, unify, Fails) where - -import Core.TT -import Core.Evaluate - -import Control.Monad -import Control.Monad.State -import Data.List -import Debug.Trace - --- Unification is applied inside the theorem prover. We're looking for holes --- which can be filled in, by matching one term's normal form against another. --- Returns a list of hole names paired with the term which solves them, and --- a list of things which need to be injective. - --- terms which need to be injective, with the things we're trying to unify --- at the time - -type Injs = [(TT Name, TT Name, TT Name)] -type Fails = [(TT Name, TT Name, Env, Err)] - -data UInfo = UI Int Fails - deriving Show - -data UResult a = UOK a - | UPartOK a - | UFail Err - --- Solve metavariables by matching terms against each other --- Not really unification, of course! - -match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> - TC [(Name, TT Name)] -match_unify ctxt env topx topy dont holes = - case runStateT (un [] topx topy) (UI 0 []) of - OK (v, UI _ []) -> return (filter notTrivial v) - res -> - let topxn = normalise ctxt env topx - topyn = normalise ctxt env topy in - case runStateT (un [] topxn topyn) - (UI 0 []) of - OK (v, UI _ fails) -> - return (filter notTrivial v) - Error e -> - -- just normalise the term we're matching against - case runStateT (un [] topxn topy) - (UI 0 []) of - OK (v, UI _ fails) -> - return (filter notTrivial v) - _ -> tfail e - where - un names (P _ x _) tm - | holeIn env x || x `elem` holes - = do sc 1; checkCycle names (x, tm) - un names tm (P _ y _) - | holeIn env y || y `elem` holes - = do sc 1; checkCycle names (y, tm) - un bnames (V i) (P _ x _) - | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] - un bnames (P _ x _) (V i) - | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] - un bnames (Bind x bx sx) (Bind y by sy) - = do h1 <- uB bnames bx by - h2 <- un ((x, y) : bnames) sx sy - combine bnames h1 h2 - un names (App fx ax) (App fy ay) - = do hf <- un names fx fy - ha <- un names ax ay - combine names hf ha - un names x y - | OK True <- convEq' ctxt x y = do sc 1; return [] - | otherwise = do UI s f <- get - let r = recoverable x y - let err = CantUnify r - topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s - if (not r) then lift $ tfail err - else do put (UI s ((x, y, env, err) : f)) - lift $ tfail err - - - uB bnames (Let tx vx) (Let ty vy) = do h1 <- un bnames tx ty - h2 <- un bnames vx vy - combine bnames h1 h2 - uB bnames (Lam tx) (Lam ty) = un bnames tx ty - uB bnames (Pi tx) (Pi ty) = un bnames tx ty - uB bnames x y = do UI s f <- get - let r = recoverable (binderTy x) (binderTy y) - let err = CantUnify r topx topy - (CantUnify r (binderTy x) (binderTy y) (Msg "") [] s) - (errEnv env) s - put (UI s ((binderTy x, binderTy y, env, err) : f)) - return [] - - -- TODO: there's an annoying amount of repetition between this and the - -- main unification function. Consider lifting it out. - - sc i = do UI s f <- get - put (UI (s+i) f) - - unifyFail x y = do UI s f <- get - let r = recoverable x y - let err = CantUnify r - topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s - put (UI s ((x, y, env, err) : f)) - lift $ tfail err - combine bnames as [] = return as - combine bnames as ((n, t) : bs) - = case lookup n as of - Nothing -> combine bnames (as ++ [(n,t)]) bs - Just t' -> do ns <- un bnames t t' - -- make sure there's n mapping from n in ns - let ns' = filter (\ (x, _) -> x/=n) ns - sc 1 - combine bnames as (ns' ++ bs) - - checkCycle ns p@(x, P _ _ _) = return [p] - checkCycle ns (x, tm) - | not (x `elem` freeNames tm) = checkScope ns (x, tm) - | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) - - checkScope ns (x, tm) = - case boundVs (envPos x 0 env) tm of - [] -> return [(x, tm)] - (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i)) - (inst ns tm) (errEnv env)) - where inst [] tm = tm - inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm) - -notTrivial (x, P _ x' _) = x /= x' -notTrivial _ = True - -expandLets env (x, tm) = (x, doSubst (reverse env) tm) - where - doSubst [] tm = tm - doSubst ((n, Let v t) : env) tm - = doSubst env (subst n v tm) - doSubst (_ : env) tm - = doSubst env tm - - -unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> - TC ([(Name, TT Name)], Fails) -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 - OK (v, UI _ []) -> return (filter notTrivial v, - []) - res -> - let topxn = normalise ctxt env topx - topyn = normalise ctxt env topy in --- trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n" ++ show res ++ "\n\n") $ - case runStateT (un False [] topxn topyn) - (UI 0 []) of - OK (v, UI _ fails) -> - return (filter notTrivial v, reverse fails) --- Error e@(CantUnify False _ _ _ _ _) -> tfail e - Error e -> tfail e - where - headDiff (P (DCon _ _) x _) (P (DCon _ _) y _) = x /= y - headDiff (P (TCon _ _) x _) (P (TCon _ _) y _) = x /= y - headDiff _ _ = False - - injective (P (DCon _ _) _ _) = True - injective (P (TCon _ _) _ _) = True --- 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 - notP _ = True - - sc i = do UI s f <- get - put (UI (s+i) f) - - errors = do UI s f <- get - return (not (null f)) - - uplus u1 u2 = do UI s f <- get - r <- u1 - UI s f' <- get - if (length f == length f') - then return r - else do put (UI s f); u2 - - un :: Bool -> [(Name, Name)] -> TT Name -> TT Name -> - StateT UInfo - TC [(Name, TT Name)] - un = un' --- un fn names x y --- = let (xf, _) = unApply x --- (yf, _) = unApply y in --- if headDiff xf yf then unifyFail x y else --- uplus (un' fn names x y) --- (un' fn names (hnf ctxt env x) (hnf ctxt env y)) - - un' :: Bool -> [(Name, Name)] -> TT Name -> TT Name -> - StateT UInfo - TC [(Name, TT Name)] - un' fn names x y | x == y = return [] -- shortcut - un' fn names topx@(P (DCon _ _) x _) topy@(P (DCon _ _) y _) - | x /= y = unifyFail topx topy - un' fn names topx@(P (TCon _ _) x _) topy@(P (TCon _ _) y _) - | x /= y = unifyFail topx topy - un' fn names topx@(P (DCon _ _) x _) topy@(P (TCon _ _) y _) - = 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) - = unifyTmpFail tx ty - | injective ty && not (holeIn env x || x `elem` holes) - = unifyTmpFail tx ty - un' fn bnames xtm@(P _ x _) tm - | holeIn env x || x `elem` holes - = do UI s f <- get - -- injectivity check - if (notP tm && fn) --- trace (show (x, tm, normalise ctxt env tm)) $ --- put (UI s ((tm, topx, topy) : i) f) - then unifyTmpFail xtm tm - else do sc 1 - checkCycle bnames (x, tm) - | not (injective xtm) && injective tm = unifyFail xtm tm - un' fn bnames tm ytm@(P _ y _) - | holeIn env y || y `elem` holes - = do UI s f <- get - -- injectivity check - if (notP tm && fn) --- trace (show (y, tm, normalise ctxt env tm)) $ --- put (UI s ((tm, topx, topy) : i) f) - then unifyTmpFail tm ytm - else do sc 1 - checkCycle bnames (y, tm) - | not (injective ytm) && injective tm = unifyFail ytm tm - un' fn bnames (V i) (P _ x _) - | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] - un' fn bnames (P _ x _) (V i) - | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] - - un' fn bnames appx@(App _ _) appy@(App _ _) - = unApp fn bnames appx appy --- = uplus (unApp fn bnames appx appy) --- (unifyTmpFail appx appy) -- take the whole lot - - un' fn bnames x (Bind n (Lam t) (App y (P Bound n' _))) - | 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) --- = un' False ((x,y):bnames) sx sy - - -- f D unifies with t -> D. This is dubious, but it helps with type - -- class resolution for type classes over functions. - - un' fn bnames (App f x) (Bind n (Pi t) y) - | noOccurrence n y && x == y - = un' False bnames f (Bind (MN 0 "uv") (Lam (TType (UVar 0))) - (Bind n (Pi t) (V 1))) - - un' fn bnames (Bind x bx sx) (Bind y by sy) - = do h1 <- uB bnames bx by - h2 <- un' False ((x,y):bnames) sx sy - combine bnames h1 h2 - un' fn bnames x y - | OK True <- convEq' ctxt x y = do sc 1; return [] - | otherwise = do UI s f <- get - let r = recoverable x y - let err = CantUnify r - topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s - if (not r) then lift $ tfail err - else do put (UI s ((x, y, env, err) : f)) - return [] -- lift $ tfail err - - unApp fn bnames appx@(App fx ax) appy@(App fy ay) - | (injective fx && injective fy) - || (injective fx && rigid appx && metavarApp appy) - || (injective fy && rigid appy && metavarApp appx) - || (injective fx && metavarApp fy && ax == ay) - || (injective fy && metavarApp fx && ax == ay) - = do let (headx, _) = unApply fx - let (heady, _) = unApply fy - -- fail quickly if the heads are disjoint - checkHeads headx heady --- if True then -- (injective fx || injective fy || fx == fy) then --- if (injective fx && metavarApp appy) || --- (injective fy && metavarApp appx) || --- (injective fx && injective fy) || fx == fy - uplus - (do hf <- un' True bnames fx fy - let ax' = hnormalise hf ctxt env (substNames hf ax) - let ay' = hnormalise hf ctxt env (substNames hf ay) - ha <- un' False bnames ax' ay' - sc 1 - combine bnames hf ha) - (do ha <- un' False bnames ax ay - let fx' = hnormalise ha ctxt env (substNames ha fx) - let fy' = hnormalise ha ctxt env (substNames ha fy) - hf <- un' False bnames fx' fy' - sc 1 - combine bnames hf ha) - | otherwise = -- trace (show (appx, appy, injective fx, metavarApp appy, sameArgStruct appx appy)) $ - do let (headx, argsx) = unApply appx - let (heady, argsy) = unApply appy - -- traceWhen (headx == heady) (show (appx, appy)) $ - uplus ( - if (length argsx == length argsy && - ((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 - failed <- errors - if (not failed) then unArgs uf argsx argsy - else return [] - else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $ - unifyTmpFail appx appy) - (unifyTmpFail appx appy) -- whole application fails - where hnormalise [] _ _ t = 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 _) - | x /= y = unifyFail appx appy - checkHeads (P (DCon _ _) x _) (P (TCon _ _) y _) - = unifyFail appx appy - checkHeads (P (TCon _ _) x _) (P (DCon _ _) y _) - = unifyFail appx appy - checkHeads _ _ = return [] - - unArgs as [] [] = return as - unArgs as (x : xs) (y : ys) - = do let x' = hnormalise as ctxt env (substNames as x) - let y' = hnormalise as ctxt env (substNames as y) - as' <- un' False bnames x' y' - vs <- combine bnames as as' - unArgs vs xs ys - - metavarApp tm = let (f, args) = unApply tm in - metavar f && - all (\x -> metavarApp x) args - && nub args == args - metavarArgs tm = let (f, args) = unApply tm in - all (\x -> metavar x || inenv x) args - && nub args == args - metavarApp' tm = let (f, args) = unApply tm in - all (\x -> pat x || metavar x) (f : args) - && nub args == args - - sameArgStruct appx appy - = let (_, ax) = unApply appx - (_, ay) = unApply appy in - length ax == length ay && - 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 - - rigid (P (DCon _ _) _ _) = True - rigid (P (TCon _ _) _ _) = True - rigid t@(P Ref _ _) = inenv t - rigid (Constant _) = True - rigid (App f a) = rigid f && rigid a - rigid t = not (metavar t) - - metavar t = case t of - 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 - - notFn t = injective t || metavar t || inenv t - - - unifyTmpFail x y - = do UI s f <- get - let r = recoverable x y - let err = CantUnify r - topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s - put (UI s ((topx, topy, env, err) : f)) - return [] - - -- shortcut failure, if we *know* nothing can fix it - unifyFail x y = do UI s f <- get - let r = recoverable x y - let err = CantUnify r - topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s - put (UI s ((topx, topy, env, err) : f)) - lift $ tfail err - - - uB bnames (Let tx vx) (Let ty vy) - = do h1 <- un' False bnames tx ty - h2 <- un' False bnames vx vy - sc 1 - combine bnames h1 h2 - uB bnames (Guess tx vx) (Guess ty vy) - = do h1 <- un' False bnames tx ty - h2 <- un' False bnames vx vy - sc 1 - combine bnames h1 h2 - uB bnames (Lam tx) (Lam ty) = do sc 1; un' False bnames tx ty - uB bnames (Pi tx) (Pi ty) = do sc 1; un' False bnames tx ty - uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty - uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty - uB bnames x y = do UI s f <- get - let r = recoverable (binderTy x) (binderTy y) - let err = CantUnify r topx topy - (CantUnify r (binderTy x) (binderTy y) (Msg "") [] s) - (errEnv env) s - put (UI s ((binderTy x, binderTy y, env, err) : f)) - return [] -- lift $ tfail err - - checkCycle ns p@(x, P _ _ _) = return [p] - checkCycle ns (x, tm) - | not (x `elem` freeNames tm) = checkScope ns (x, tm) - | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) - - checkScope ns (x, tm) = - case boundVs (envPos x 0 env) tm of - [] -> return [(x, tm)] - (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i)) - (inst ns tm) (errEnv env)) - where inst [] tm = tm - inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm) - - combineArgs bnames args = ca [] args where - ca acc [] = return acc - ca acc (x : xs) = do x' <- combine bnames acc x - ca x' xs - - combine bnames as [] = return as - combine bnames as ((n, t) : bs) - = case lookup n as of - Nothing -> combine bnames (as ++ [(n,t)]) bs - Just t' -> do ns <- un' False bnames t t' - -- make sure there's n mapping from n in ns - let ns' = filter (\ (x, _) -> x/=n) ns - sc 1 - combine bnames as (ns' ++ bs) - -boundVs :: Int -> Term -> [Int] -boundVs i (V j) | j <= i = [] - | otherwise = [j] -boundVs i (Bind n b sc) = boundVs (i + 1) sc -boundVs i (App f x) = let fs = boundVs i f - xs = boundVs i x in - nub (fs ++ xs) -boundVs i _ = [] - -envPos x i [] = 0 -envPos x i ((y, _) : ys) | x == y = i - | otherwise = envPos x (i + 1) ys - - --- If there are any clashes of constructors, deem it unrecoverable, otherwise some --- more work may help. --- FIXME: Depending on how overloading gets used, this may cause problems. Better --- rethink overloading properly... - -recoverable (P (DCon _ _) x _) (P (DCon _ _) y _) - | x == y = True - | otherwise = False -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') - = recoverable f f' -- && recoverable a a' -recoverable _ _ = True - -errEnv = map (\(x, b) -> (x, binderTy b)) - -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 - diff --git a/src/IRTS/BCImp.hs b/src/IRTS/BCImp.hs --- a/src/IRTS/BCImp.hs +++ b/src/IRTS/BCImp.hs @@ -5,7 +5,7 @@ import IRTS.Lang import IRTS.Simplified -import Core.TT +import Idris.Core.TT data Reg = RVal | L Int diff --git a/src/IRTS/Bytecode.hs b/src/IRTS/Bytecode.hs --- a/src/IRTS/Bytecode.hs +++ b/src/IRTS/Bytecode.hs @@ -5,7 +5,7 @@ import IRTS.Lang import IRTS.Simplified -import Core.TT +import Idris.Core.TT import Data.Maybe {- We have: diff --git a/src/IRTS/CodegenC.hs b/src/IRTS/CodegenC.hs --- a/src/IRTS/CodegenC.hs +++ b/src/IRTS/CodegenC.hs @@ -4,11 +4,13 @@ import IRTS.Bytecode import IRTS.Lang import IRTS.Simplified +import IRTS.System import IRTS.CodegenCommon -import Core.TT +import Idris.Core.TT import Paths_idris import Util.System +import Numeric import Data.Char import Data.List (intercalate) import System.Process @@ -103,6 +105,22 @@ indent 1 ++ "INITFRAME;\n" ++ concatMap (bcc 1) code ++ "}\n\n" +showCStr :: String -> String +showCStr s = '"' : foldr ((++) . showChar) "\"" s + where + showChar :: Char -> String + showChar '"' = "\\\"" + showChar '\\' = "\\\\" + showChar c + -- Note: we need the double quotes around the codes because otherwise + -- "\n3" would get encoded as "\x0a3", which is incorrect. + -- Instead, we opt for "\x0a""3" and let the C compiler deal with it. + | ord c < 0x10 = "\"\"\\x0" ++ showHex (ord c) "\"\"" + | ord c < 0x20 = "\"\"\\x" ++ showHex (ord c) "\"\"" + | ord c < 0x7f = [c] -- 0x7f = \DEL + | ord c < 0x100 = "\"\"\\x" ++ showHex (ord c) "\"\"" + | otherwise = error $ "non-8-bit character in string literal: " ++ show c + bcc :: Int -> BC -> String bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n" bcc i (ASSIGNCONST l c) @@ -113,7 +131,7 @@ | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")" mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")" mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")" - mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")" + mkConst (Str s) = "MKSTR(vm, " ++ showCStr 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 ++ ")" @@ -439,11 +457,16 @@ doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")" doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")" +doOp v LAllocate [x] = v ++ "idris_allocate(vm, " ++ creg x ++ ")" +doOp v LAppendBuffer [a, b, c, d, e, f] = v ++ "idris_appendBuffer(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ "," ++ creg e ++ "," ++ creg f ++ ")" +doOp v (LAppend ity en) [a, b, c, d] = v ++ "idris_append" ++ intTyName ity ++ show en ++ "(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ ")" +doOp v (LPeek ity en) [x, y] = v ++ "idris_peek" ++ intTyName ity ++ show en ++ "(vm, " ++ creg x ++ "," ++ creg y ++ ")" + doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)" doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)" doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)" -doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" +doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 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 LNullPtr [] = v ++ "MKPTR(vm, NULL)" diff --git a/src/IRTS/CodegenCommon.hs b/src/IRTS/CodegenCommon.hs --- a/src/IRTS/CodegenCommon.hs +++ b/src/IRTS/CodegenCommon.hs @@ -1,6 +1,6 @@ module IRTS.CodegenCommon where -import Core.TT +import Idris.Core.TT import IRTS.Simplified import Control.Exception diff --git a/src/IRTS/CodegenJava.hs b/src/IRTS/CodegenJava.hs --- a/src/IRTS/CodegenJava.hs +++ b/src/IRTS/CodegenJava.hs @@ -1,7 +1,7 @@ {-# LANGUAGE PatternGuards #-} module IRTS.CodegenJava (codegenJava) where -import Core.TT hiding (mkApp) +import Idris.Core.TT hiding (mkApp) import IRTS.CodegenCommon import IRTS.Java.ASTBuilding import IRTS.Java.JTypes @@ -9,6 +9,7 @@ import IRTS.Java.Pom (pomString) import IRTS.Lang import IRTS.Simplified +import IRTS.System import Util.System import Control.Applicative hiding (Const) @@ -368,13 +369,13 @@ | otherwise = decls where findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_) - | name == mangle' (UN "Main") = findMainMethod body + | name == mangle' (sUN "Main") = findMainMethod body findMain (_:decls) = findMain decls findMain [] = False - innerMainMethod = (either error id $ mangle (UN "main")) + innerMainMethod = (either error id $ mangle (sUN "main")) findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_) - | name == mangle' (UN "main") = True + | name == mangle' (sUN "main") = True findMainMethod (_:decls) = findMainMethod decls findMainMethod [] = False @@ -389,7 +390,7 @@ $ call "idris_initArgs" [ (threadType ~> "currentThread") [] , jConst "args" ] - , BlockStmt . ExpStmt $ call (mangle' (MN 0 "runMain")) [] + , BlockStmt . ExpStmt $ call (mangle' (sMN 0 "runMain")) [] ] ----------------------------------------------------------------------- @@ -748,6 +749,6 @@ mkThread :: LVar -> CodeGeneration Exp mkThread arg = - (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (MN 0 "EVAL") [arg] + (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (sMN 0 "EVAL") [arg] diff --git a/src/IRTS/CodegenJavaScript.hs b/src/IRTS/CodegenJavaScript.hs --- a/src/IRTS/CodegenJavaScript.hs +++ b/src/IRTS/CodegenJavaScript.hs @@ -7,1128 +7,1654 @@ import IRTS.Lang import IRTS.Simplified import IRTS.CodegenCommon -import Core.TT -import Paths_idris -import Util.System - -import Control.Arrow -import Control.Applicative ((<$>), (<*>), pure) -import Data.Char -import Data.List -import Data.Maybe -import System.IO -import System.Directory - -idrNamespace :: String -idrNamespace = "__IDR__" -idrRTNamespace = "__IDRRT__" -idrLTNamespace = "__IDRLT__" - -data JSTarget = Node | JavaScript deriving Eq - -data JSType = JSIntTy - | JSStringTy - | JSIntegerTy - | JSFloatTy - | JSCharTy - | JSPtrTy - | JSForgotTy - deriving Eq - -data JSInteger = JSBigZero - | JSBigOne - | JSBigInt Integer - deriving Eq - -data JSNum = JSInt Int - | JSFloat Double - | JSInteger JSInteger - deriving Eq - -data JS = JSRaw String - | JSIdent String - | JSFunction [String] JS - | JSType JSType - | JSSeq [JS] - | JSReturn JS - | JSApp JS [JS] - | JSNew String [JS] - | JSError String - | JSOp String JS JS - | JSProj JS String - | JSVar LVar - | JSNull - | JSThis - | JSTrue - | JSFalse - | JSArray [JS] - | JSObject [(String, JS)] - | JSString String - | JSNum JSNum - | JSAssign JS JS - | JSAlloc String (Maybe JS) - | JSIndex JS JS - | JSCond [(JS, JS)] - | JSTernary JS JS JS - deriving Eq - -compileJS :: JS -> String -compileJS (JSRaw code) = - code - -compileJS (JSIdent ident) = - ident - -compileJS (JSFunction args body) = - "function(" - ++ intercalate "," args - ++ "){\n" - ++ compileJS body - ++ "\n}" - -compileJS (JSType ty) - | JSIntTy <- ty = idrRTNamespace ++ "Int" - | JSStringTy <- ty = idrRTNamespace ++ "String" - | JSIntegerTy <- ty = idrRTNamespace ++ "Integer" - | JSFloatTy <- ty = idrRTNamespace ++ "Float" - | JSCharTy <- ty = idrRTNamespace ++ "Char" - | JSPtrTy <- ty = idrRTNamespace ++ "Ptr" - | JSForgotTy <- ty = idrRTNamespace ++ "Forgot" - -compileJS (JSSeq seq) = - intercalate ";\n" (map compileJS seq) - -compileJS (JSReturn val) = - "return " ++ compileJS val - -compileJS (JSApp lhs rhs) - | JSFunction {} <- lhs = - concat ["(", compileJS lhs, ")(", args, ")"] - | otherwise = - concat [compileJS lhs, "(", args, ")"] - where args :: String - args = intercalate "," $ map compileJS rhs - -compileJS (JSNew name args) = - "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")" - -compileJS (JSError exc) = - "(function(){throw '" ++ exc ++ "';})()" - -compileJS (JSOp op lhs rhs) = - compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs - -compileJS (JSProj obj field) - | JSFunction {} <- obj = - concat ["(", compileJS obj, ").", field] - | JSAssign {} <- obj = - concat ["(", compileJS obj, ").", field] - | otherwise = - compileJS obj ++ '.' : field - -compileJS (JSVar var) = - translateVariableName var - -compileJS JSNull = - "null" - -compileJS JSThis = - "this" - -compileJS JSTrue = - "true" - -compileJS JSFalse = - "false" - -compileJS (JSArray elems) = - "[" ++ intercalate "," (map compileJS elems) ++ "]" - -compileJS (JSObject fields) = - "{" ++ intercalate ",\n" (map compileField fields) ++ "}" - where - compileField :: (String, JS) -> String - compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val - -compileJS (JSString str) = - show str - -compileJS (JSNum num) - | JSInt i <- num = show i - | JSFloat f <- num = show f - | JSInteger JSBigZero <- num = "__IDRRT__ZERO" - | JSInteger JSBigOne <- num = "__IDRRT__ONE" - | JSInteger (JSBigInt i) <- num = show i - -compileJS (JSAssign lhs rhs) = - compileJS lhs ++ "=" ++ compileJS rhs - -compileJS (JSAlloc name val) = - "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val - -compileJS (JSIndex lhs rhs) = - compileJS lhs ++ "[" ++ compileJS rhs ++ "]" - -compileJS (JSCond branches) = - intercalate " else " $ map createIfBlock branches - where - createIfBlock (cond, e) = - "if (" ++ compileJS cond ++") {\n" - ++ "return " ++ compileJS e - ++ ";\n}" - -compileJS (JSTernary cond true false) = - let c = compileJS cond - t = compileJS true - f = compileJS false in - "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")" - -jsTailcall :: JS -> JS -jsTailcall call = - jsCall (idrRTNamespace ++ "tailcall") [ - JSFunction [] (JSReturn call) - ] - -jsCall :: String -> [JS] -> JS -jsCall fun = JSApp (JSIdent fun) - -jsMeth :: JS -> String -> [JS] -> JS -jsMeth obj meth = - JSApp (JSProj obj meth) - -jsInstanceOf :: JS -> JS -> JS -jsInstanceOf = JSOp "instanceof" - -jsEq :: JS -> JS -> JS -jsEq = JSOp "==" - -jsAnd :: JS -> JS -> JS -jsAnd = JSOp "&&" - -jsType :: JS -jsType = JSIdent $ idrRTNamespace ++ "Type" - -jsCon :: JS -jsCon = JSIdent $ idrRTNamespace ++ "Con" - -jsTag :: JS -> JS -jsTag obj = JSProj obj "tag" - -jsTypeTag :: JS -> JS -jsTypeTag obj = JSProj obj "type" - -jsBigInt :: JS -> JS -jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero -jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne -jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val] - -jsVar :: Int -> String -jsVar = ("__var_" ++) . show - -jsLet :: String -> JS -> JS -> JS -jsLet name value body = - JSApp ( - JSFunction [name] ( - JSReturn body - ) - ) [value] - -jsSubst :: String -> JS -> JS -> JS -jsSubst var new (JSVar old) - | var == translateVariableName old = new - | otherwise = JSVar old - -jsSubst var new (JSIdent old) - | var == old = new - | otherwise = JSIdent old - -jsSubst var new (JSArray fields) = - JSArray (map (jsSubst var new) fields) - -jsSubst var new (JSNew con [tag, vals]) = - JSNew con [tag, jsSubst var new vals] - -jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) = - JSNew con [JSFunction [] ( - JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) vars) - )] - -jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( - JSReturn (JSApp fun args) - )]) = - JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( - JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) args) - )] - -jsSubst var new (JSApp (JSProj obj field) args) = - JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args - -jsSubst var new (JSApp (JSFunction [arg] body) vals) - | var /= arg = - JSApp (JSFunction [arg] ( - jsSubst var new body - )) $ map (jsSubst var new) vals - | otherwise = - JSApp (JSFunction [arg] ( - body - )) $ map (jsSubst var new) vals - -jsSubst var new (JSReturn ret) = - JSReturn $ jsSubst var new ret - -jsSubst var new (JSProj obj field) = - JSProj (jsSubst var new obj) field - -jsSubst var new (JSSeq body) = - JSSeq $ map (jsSubst var new) body - -jsSubst var new (JSOp op lhs rhs) = - JSOp op (jsSubst var new lhs) (jsSubst var new rhs) - -jsSubst var new (JSIndex obj field) = - JSIndex (jsSubst var new obj) (jsSubst var new field) - -jsSubst var new (JSCond conds) = - JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds) - -jsSubst _ _ js = js - -inlineJS :: JS -> JS -inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) = - JSApp (JSFunction [] (JSSeq (map inlineJS ret))) [] - -inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val]) - | JSNew con [tag, vals] <- ret - , opt <- inlineJS val = - JSNew con [tag, jsSubst arg opt vals] - - | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret - , opt <- inlineJS val = - JSNew con [JSFunction [] ( - JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) vars) - )] - - | JSApp (JSProj obj field) args <- ret - , opt <- inlineJS val = - JSApp (JSProj (jsSubst arg opt obj) field) $ map (jsSubst arg opt) args - - | JSIndex (JSProj obj field) idx <- ret - , opt <- inlineJS val = - JSIndex (JSProj ( - jsSubst arg opt obj - ) field - ) (jsSubst arg opt idx) - - | JSOp op lhs rhs <- ret - , opt <- inlineJS val = - JSOp op (jsSubst arg opt lhs) $ - (jsSubst arg opt rhs) - - | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( - JSReturn (JSApp fun args) - )] <- ret - , opt <- inlineJS val = - JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( - JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) args) - )] - -inlineJS (JSApp fun args) = - JSApp (inlineJS fun) (map inlineJS args) - -inlineJS (JSNew con args) = - JSNew con $ map inlineJS args - -inlineJS (JSArray fields) = - JSArray (map inlineJS fields) - -inlineJS (JSAssign lhs rhs) = - JSAssign (inlineJS lhs) (inlineJS rhs) - -inlineJS (JSSeq seq) = - JSSeq (map inlineJS seq) - -inlineJS (JSFunction args body) = - JSFunction args (inlineJS body) - -inlineJS (JSProj (JSFunction args body) field) = - JSProj (JSFunction args (inlineJS body)) field - -inlineJS (JSReturn js) = - JSReturn $ inlineJS js - -inlineJS (JSAlloc name (Just js)) = - JSAlloc name (Just $ inlineJS js) - -inlineJS (JSCond cases) = - JSCond (map (second inlineJS) cases) - -inlineJS (JSObject fields) = - JSObject (map (second inlineJS) fields) - -inlineJS js = js - -reduceJS :: [JS] -> [JS] -reduceJS js = reduceLoop [] ([], js) - -funName :: JS -> String -funName (JSAlloc fun _) = fun - -removeIDs :: [JS] -> [JS] -removeIDs js = - case partition isID js of - ([], rest) -> rest - (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest - where isID :: JS -> Bool - isID (JSAlloc _ (Just (JSFunction _ (JSSeq body)))) - | JSReturn (JSVar _) <- last body = True - - isID _ = False - - idFor :: JS -> (String, Int) - idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) - | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos) - - removeIDCall :: [(String, Int)] -> JS -> JS - removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( - JSReturn (JSApp (JSIdent fun) args) - )]) - | Just pos <- lookup fun ids - , pos < length args = args !! pos - - removeIDCall ids (JSNew _ [JSFunction [] ( - JSReturn (JSApp (JSIdent fun) args) - )]) - | Just pos <- lookup fun ids - , pos < length args = args !! pos - - removeIDCall ids js@(JSApp id@(JSIdent fun) args) - | Just pos <- lookup fun ids - , pos < length args = args !! pos - - removeIDCall ids (JSAlloc fun (Just body)) = - JSAlloc fun (Just $ removeIDCall ids body) - - removeIDCall ids (JSReturn js) = - JSReturn $ removeIDCall ids js - - removeIDCall ids (JSSeq js) = - JSSeq $ map (removeIDCall ids) js - - removeIDCall ids (JSNew con args) = - JSNew con $ map (removeIDCall ids) args - - removeIDCall ids (JSFunction args body) = - JSFunction args $ removeIDCall ids body - - removeIDCall ids (JSApp fun args) = - JSApp (removeIDCall ids fun) $ map (removeIDCall ids) args - - removeIDCall ids (JSProj obj field) = - JSProj (removeIDCall ids obj) field - - removeIDCall ids (JSCond conds) = - JSCond $ map (removeIDCall ids *** removeIDCall ids) conds - - removeIDCall ids (JSAssign lhs rhs) = - JSAssign (removeIDCall ids lhs) (removeIDCall ids rhs) - - removeIDCall ids (JSArray fields) = - JSArray $ map (removeIDCall ids) fields - - removeIDCall _ js = js - -reduceConstant :: JS -> JS -reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( - JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num]) - )]) = JSNum num - -reduceConstant (JSReturn ret) = - JSReturn (reduceConstant ret) - -reduceConstant (JSApp fun args) = - JSApp (reduceConstant fun) (map reduceConstant args) - -reduceConstant (JSArray fields) = - JSArray (map reduceConstant fields) - -reduceConstant (JSAlloc name (Just val)) = - JSAlloc name $ Just (reduceConstant val) - -reduceConstant (JSNew con args) = - JSNew con (map reduceConstant args) - -reduceConstant (JSProj obj field) = - JSProj (reduceConstant obj) field - -reduceConstant (JSCond conds) = - JSCond $ map (reduceConstant *** reduceConstant) conds - -reduceConstant (JSSeq seq) = - JSSeq $ map reduceConstant seq - -reduceConstant (JSFunction args body) = - JSFunction args (reduceConstant body) - -reduceConstant js = js - -reduceConstants :: JS -> JS -reduceConstants js - | ret <- reduceConstant js - , ret /= js = reduceConstants ret - | otherwise = js - -reduceLoop :: [String] -> ([JS], [JS]) -> [JS] -reduceLoop reduced (cons, program) = - case partition findConstructors program of - ([], js) -> cons ++ js - (candidates, rest) -> - let names = reduced ++ map funName candidates in - reduceLoop names ( - cons ++ map reduce candidates, map (reduceCall names) rest - ) - where findConstructors :: JS -> Bool - findConstructors js - | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js = - reducable $ last body - | otherwise = False - where reducable :: JS -> Bool - reducable (JSReturn js) = reducable js - reducable (JSNew _ args) = and $ map reducable args - reducable (JSArray fields) = and $ map reducable fields - reducable (JSNum _) = True - reducable JSNull = True - reducable (JSIdent _) = True - reducable _ = False - - reduce :: JS -> JS - reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) - | JSReturn js <- last body = (JSAlloc fun (Just js)) - - reduce js = js - - reduceCall :: [String] -> JS -> JS - reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( - JSReturn (JSApp id@(JSIdent ret) _) - )]) - | ret `elem` funs = id - - reduceCall funs js@(JSApp id@(JSIdent fun) _) - | fun `elem` funs = id - - reduceCall funs (JSAlloc fun (Just body)) = - JSAlloc fun (Just $ reduceCall funs body) - - reduceCall funs (JSReturn js) = - JSReturn $ reduceCall funs js - - reduceCall funs (JSSeq js) = - JSSeq $ map (reduceCall funs) js - - reduceCall funs (JSNew con args) = - JSNew con $ map (reduceCall funs) args - - reduceCall funs (JSFunction args body) = - JSFunction args $ reduceCall funs body - - reduceCall funs (JSApp fun args) = - JSApp (reduceCall funs fun) $ map (reduceCall funs) args - - reduceCall funs (JSProj obj field) = - JSProj (reduceCall funs obj) field - - reduceCall funs (JSCond conds) = - JSCond $ map (reduceCall funs *** reduceCall funs) conds - - reduceCall funs (JSAssign lhs rhs) = - JSAssign (reduceCall funs lhs) (reduceCall funs rhs) - - reduceCall funs (JSArray fields) = - JSArray $ map (reduceCall funs) fields - - reduceCall _ js = js - -optimizeJS :: JS -> JS -optimizeJS = inlineLoop - where inlineLoop :: JS -> JS - inlineLoop js - | opt <- inlineJS js - , opt /= js = inlineLoop opt - | otherwise = js - -codegenJavaScript - :: JSTarget - -> [(Name, SDecl)] - -> FilePath - -> OutputType - -> IO () -codegenJavaScript target definitions filename outputType = do - let (header, runtime) = case target of - Node -> - ("#!/usr/bin/env node\n", "-node") - JavaScript -> - ("", "-browser") - path <- (++) <$> getDataDir <*> (pure "/jsrts/") - idrRuntime <- readFile $ path ++ "Runtime-common.js" - tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"] - jsbn <- readFile $ path ++ "jsbn/jsbn.js" - writeFile filename $ header ++ ( - intercalate "\n" $ [ jsbn - , idrRuntime - , tgtRuntime - ] ++ functions ++ [mainLoop, invokeLoop] - ) - - setPermissions filename (emptyPermissions { readable = True - , executable = target == Node - , writable = True - }) - where - def :: [(String, SDecl)] - def = map (first translateNamespace) definitions - - functions :: [String] - functions = - map (compileJS . reduceConstants) ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def) - - mainLoop :: String - mainLoop = compileJS $ - JSAlloc "main" $ Just $ JSFunction [] ( - case target of - Node -> mainFun - JavaScript -> jsMeth (JSIdent "window") "addEventListener" [ - JSString "DOMContentLoaded", JSFunction [] ( - mainFun - ), JSFalse - ] - ) - where - mainFun :: JS - mainFun = jsTailcall $ jsCall runMain [] - - runMain :: String - runMain = idrNamespace ++ translateName (MN 0 "runMain") - - invokeLoop :: String - invokeLoop = compileJS $ jsCall "main" [] - -translateIdentifier :: String -> String -translateIdentifier = - replaceReserved . concatMap replaceBadChars - where replaceBadChars :: Char -> String - replaceBadChars c - | ' ' <- c = "_" - | '_' <- c = "__" - | isDigit c = '_' : show (ord c) - | not (isLetter c && isAscii c) = '_' : show (ord c) - | otherwise = [c] - replaceReserved s - | s `elem` reserved = '_' : s - | otherwise = s - reserved = [ "break" - , "case" - , "catch" - , "continue" - , "debugger" - , "default" - , "delete" - , "do" - , "else" - , "finally" - , "for" - , "function" - , "if" - , "in" - , "instanceof" - , "new" - , "return" - , "switch" - , "this" - , "throw" - , "try" - , "typeof" - , "var" - , "void" - , "while" - , "with" - - , "class" - , "enum" - , "export" - , "extends" - , "import" - , "super" - - , "implements" - , "interface" - , "let" - , "package" - , "private" - , "protected" - , "public" - , "static" - , "yield" - ] - -translateNamespace :: Name -> String -translateNamespace (UN _) = idrNamespace -translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns -translateNamespace (MN _ _) = idrNamespace -translateNamespace (SN name) = idrNamespace ++ translateSpecialName name -translateNamespace NErased = idrNamespace - -translateName :: Name -> String -translateName (UN name) = 'u' : translateIdentifier name -translateName (NS name _) = 'n' : translateName name -translateName (MN i name) = 'm' : translateIdentifier name ++ show i -translateName (SN name) = 's' : translateSpecialName name -translateName NErased = "e" - -translateSpecialName :: SpecialName -> String -translateSpecialName name - | WhereN i m n <- name = - 'w' : translateName m ++ translateName n ++ show i - | InstanceN n s <- name = - 'i' : translateName n ++ concatMap translateIdentifier s - | ParentN n s <- name = - 'p' : translateName n ++ translateIdentifier s - | MethodN n <- name = - 'm' : translateName n - | CaseN n <- name = - 'c' : translateName n - -translateConstant :: Const -> JS -translateConstant (I i) = JSNum (JSInt i) -translateConstant (Fl f) = JSNum (JSFloat f) -translateConstant (Ch c) = JSString [c] -translateConstant (Str s) = JSString s -translateConstant (AType (ATInt ITNative)) = JSType JSIntTy -translateConstant StrType = JSType JSStringTy -translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy -translateConstant (AType ATFloat) = JSType JSFloatTy -translateConstant (AType (ATInt ITChar)) = JSType JSCharTy -translateConstant PtrType = JSType JSPtrTy -translateConstant Forgot = JSType JSForgotTy -translateConstant (BI i) = jsBigInt $ JSString (show i) -translateConstant c = - JSError $ "Unimplemented Constant: " ++ show c - -translateDeclaration :: (String, SDecl) -> JS -translateDeclaration (path, SFun name params stackSize body) - | (MN _ "APPLY") <- name - , (SLet var val next) <- body - , (SChkCase cvar cases) <- next = - let lvar = translateVariableName var - lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in - JSSeq [ lookupTable [(var, "chk")] var cases - , jsDecl $ JSFunction ["fn0", "arg0"] ( - JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0") - , JSReturn $ jsLet (translateVariableName var) ( - translateExpression val - ) (JSTernary ( - (JSVar var `jsInstanceOf` jsCon) `jsAnd` - (hasProp lookupTableName (translateVariableName var)) - ) (JSIdent $ - lookupTableName ++ lookup - ) JSNull - ) - ] - ) - ] - - | (MN _ "EVAL") <- name - , (SChkCase var cases) <- body = - JSSeq [ lookupTable [] var cases - , jsDecl $ JSFunction ["arg0"] (JSReturn $ - JSTernary ( - (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd` - (hasProp lookupTableName "arg0") - ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSIdent "arg0") - ) - ] - | otherwise = - let fun = translateExpression body in - jsDecl $ jsFun fun - - where - hasProp :: String -> String -> JS - hasProp table var = - JSIndex (JSIdent table) (JSProj (JSIdent var) "tag") - - caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS - caseFun aux var cse = - jsFunAux aux (translateCase (Just (translateVariableName var)) cse) - - getTag :: SAlt -> Maybe Int - getTag (SConCase _ tag _ _ _) = Just tag - getTag _ = Nothing - - lookupTableName :: String - lookupTableName = idrLTNamespace ++ translateName name - - lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS - lookupTable aux var cases = - JSAlloc lookupTableName $ Just ( - JSApp (JSFunction [] ( - JSSeq $ [ - JSAlloc "t" $ Just (JSArray []) - ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [ - JSReturn (JSIdent "t") - ] - )) [] - ) - where - assignEntries :: [(Int, JS)] -> [JS] - assignEntries entries = - map (\(tag, fun) -> - JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun - ) entries - - lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS) - lookupEntry aux var alt = do - tag <- getTag alt - return (tag, caseFun aux var alt) - - jsDecl :: JS -> JS - jsDecl = JSAlloc (path ++ translateName name) . Just - - jsFun body = jsFunAux [] body - - jsFunAux :: [(LVar, String)] -> JS -> JS - jsFunAux aux body = - JSFunction (p ++ map snd aux) ( - JSSeq $ - zipWith assignVar [0..] p ++ - map allocVar [numP .. (numP + stackSize - 1)] ++ - map assignAux aux ++ - [JSReturn body] - ) - where - numP :: Int - numP = length params - - allocVar :: Int -> JS - allocVar n = JSAlloc (jsVar n) Nothing - - assignVar :: Int -> String -> JS - assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s) - - assignAux :: (LVar, String) -> JS - assignAux (var, val) = - JSAssign (JSIdent $ translateVariableName var) (JSIdent val) - - p :: [String] - p = map translateName params - -translateVariableName :: LVar -> String -translateVariableName (Loc i) = - jsVar i - -translateExpression :: SExp -> JS -translateExpression (SLet name value body) = - jsLet (translateVariableName name) ( - translateExpression value - ) (translateExpression body) - -translateExpression (SConst cst) = - translateConstant cst - -translateExpression (SV var) = - JSVar var - -translateExpression (SApp tc name vars) - | False <- tc = - jsTailcall $ translateFunctionCall name vars - | True <- tc = - JSNew (idrRTNamespace ++ "Cont") [JSFunction [] ( - JSReturn $ translateFunctionCall name vars - )] - where - translateFunctionCall name vars = - jsCall (translateNamespace name ++ translateName name) (map JSVar vars) - -translateExpression (SOp op vars) - | LNoOp <- op = JSVar (last vars) - - | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)] - | (LPlus (ATInt ITBig)) <- op - , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs] - | (LMinus (ATInt ITBig)) <- op - , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs] - | (LTimes (ATInt ITBig)) <- op - , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs] - | (LSDiv (ATInt ITBig)) <- op - , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs] - | (LSRem (ATInt ITBig)) <- op - , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs] - | (LEq (ATInt ITBig)) <- op - , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs] - | (LSLt (ATInt ITBig)) <- op - , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs] - | (LSLe (ATInt ITBig)) <- op - , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs] - | (LSGt (ATInt ITBig)) <- op - , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs] - | (LSGe (ATInt ITBig)) <- op - , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs] - - | (LPlus ATFloat) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs - | (LMinus ATFloat) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs - | (LTimes ATFloat) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs - | (LSDiv ATFloat) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs - | (LEq ATFloat) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs - | (LSLt ATFloat) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs - | (LSLe ATFloat) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs - | (LSGt ATFloat) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs - | (LSGe ATFloat) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs - - | (LPlus _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs - | (LMinus _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs - | (LTimes _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs - | (LSDiv _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs - | (LSRem _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs - | (LEq _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs - | (LSLt _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs - | (LSLe _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs - | (LSGt _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs - | (LSGe _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs - | (LAnd _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs - | (LOr _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs - | (LXOr _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs - | (LSHL _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs - | (LASHR _) <- op - , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs - | (LCompl _) <- op - , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg - - | LStrConcat <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs - | LStrEq <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs - | LStrLt <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs - | LStrLen <- op - , (arg:_) <- vars = JSProj (JSVar arg) "length" - - | (LStrInt ITNative) <- op - , (arg:_) <- vars = jsCall "parseInt" [JSVar arg] - | (LIntStr ITNative) <- op - , (arg:_) <- vars = jsCall "String" [JSVar arg] - | (LSExt ITNative ITBig) <- op - , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg] - | (LTrunc ITBig ITNative) <- op - , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" [] - | (LIntStr ITBig) <- op - , (arg:_) <- vars = jsMeth (JSVar arg) "toString" [] - | (LStrInt ITBig) <- op - , (arg:_) <- vars = jsBigInt $ JSVar arg - | LFloatStr <- op - , (arg:_) <- vars = jsCall "String" [JSVar arg] - | LStrFloat <- op - , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg] - | (LIntFloat ITNative) <- op - , (arg:_) <- vars = JSVar arg - | (LFloatInt ITNative) <- op - , (arg:_) <- vars = JSVar arg - | (LChInt ITNative) <- op - , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)" - | (LIntCh ITNative) <- op - , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg] - - | LFExp <- op - , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg] - | LFLog <- op - , (arg:_) <- vars = jsCall "Math.log" [JSVar arg] - | LFSin <- op - , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg] - | LFCos <- op - , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg] - | LFTan <- op - , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg] - | LFASin <- op - , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg] - | LFACos <- op - , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg] - | LFATan <- op - , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg] - | LFSqrt <- op - , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg] - | LFFloor <- op - , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg] - | LFCeil <- op - , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg] - - | LStrCons <- op - , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs - | LStrHead <- op - , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0)) - | LStrRev <- op - , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')" - | LStrIndex <- op - , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs) - | LStrTail <- op - , (arg:_) <- vars = let v = translateVariableName arg in - JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)" - | LNullPtr <- op - , (_) <- vars = JSNull - - where - translateBinaryOp :: String -> LVar -> LVar -> JS - translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs) - - invokeMeth :: LVar -> String -> [LVar] -> JS - invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args) - -translateExpression (SError msg) = - JSError msg - -translateExpression (SForeign _ _ "putStr" [(FString, var)]) = - jsCall (idrRTNamespace ++ "print") [JSVar var] - -translateExpression (SForeign _ _ fun args) = - ffi fun (map generateWrapper args) - where - generateWrapper (ffunc, name) - | FFunction <- ffunc = - idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")" - | FFunctionIO <- ffunc = - idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")" - - generateWrapper (_, name) = - translateVariableName name - -translateExpression patterncase - | (SChkCase var cases) <- patterncase = caseHelper var cases "chk" - | (SCase var cases) <- patterncase = caseHelper var cases "cse" - where - caseHelper var cases param = - JSApp (JSFunction [param] ( - JSCond $ map (expandCase param . translateCaseCond param) cases - )) [JSVar var] - - expandCase :: String -> (Cond, JS) -> (JS, JS) - expandCase _ (RawCond cond, branch) = (cond, branch) - expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch) - expandCase var (CaseCond caseTy, branch) - | ConCase tag <- caseTy = - let checkCon = JSIdent var `jsInstanceOf` jsCon - checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in - (checkCon `jsAnd` checkTag, branch) - - | TypeCase ty <- caseTy = - let checkTy = JSIdent var `jsInstanceOf` jsType - checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in - (checkTy `jsAnd` checkTag, branch) - -translateExpression (SCon i name vars) = - JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i - , JSArray $ map JSVar vars - ] - -translateExpression (SUpdate var@(Loc i) e) = - JSAssign (JSVar var) (translateExpression e) - -translateExpression (SProj var i) = - JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i) - -translateExpression SNothing = JSNull - -translateExpression e = - JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e) - -data FFI = FFICode Char | FFIArg Int | FFIError String - -ffi :: String -> [String] -> JS -ffi code args = let parsed = ffiParse code in - case ffiError parsed of - Just err -> JSError err - Nothing -> JSRaw $ renderFFI parsed args - where - ffiParse :: String -> [FFI] - ffiParse "" = [] - ffiParse ['%'] = [FFIError "Invalid positional argument"] - ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss - ffiParse ('%':s:ss) - | isDigit s = - FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss) - | otherwise = - [FFIError "Invalid positional argument"] - ffiParse (s:ss) = FFICode s : ffiParse ss - - ffiError :: [FFI] -> Maybe String - ffiError [] = Nothing - ffiError ((FFIError s):xs) = Just s - ffiError (x:xs) = ffiError xs - - renderFFI :: [FFI] -> [String] -> String - renderFFI [] _ = "" - renderFFI ((FFICode c) : fs) args = c : renderFFI fs args - renderFFI ((FFIArg i) : fs) args - | i < length args && i >= 0 = args !! i ++ renderFFI fs args - | otherwise = "Argument index out of bounds" - -data CaseType = ConCase Int - | TypeCase JSType - | DefaultCase - deriving Eq - -data Cond = CaseCond CaseType - | RawCond JS - -translateCaseCond :: String -> SAlt -> (Cond, JS) -translateCaseCond _ cse@(SDefaultCase _) = - (CaseCond DefaultCase, translateCase Nothing cse) - -translateCaseCond var cse@(SConstCase ty _) - | StrType <- ty = matchHelper JSStringTy - | PtrType <- ty = matchHelper JSPtrTy - | Forgot <- ty = matchHelper JSForgotTy - | (AType ATFloat) <- ty = matchHelper JSFloatTy - | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy - | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy - | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy - where - matchHelper :: JSType -> (Cond, JS) - matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse) - -translateCaseCond var cse@(SConstCase cst@(BI _) _) = - let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in - (RawCond cond, translateCase Nothing cse) - -translateCaseCond var cse@(SConstCase cst _) = - let cond = JSIdent var `jsEq` translateConstant cst in - (RawCond cond, translateCase Nothing cse) - -translateCaseCond var cse@(SConCase _ tag _ _ _) = - (CaseCond $ ConCase tag, translateCase (Just var) cse) - -translateCase :: Maybe String -> SAlt -> JS -translateCase _ (SDefaultCase e) = translateExpression e -translateCase _ (SConstCase _ e) = translateExpression e -translateCase (Just var) (SConCase a _ _ vars e) = - let params = map jsVar [a .. (a + length vars)] in - jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [ +import Idris.Core.TT +import Paths_idris +import Util.System + +import Control.Arrow +import Control.Applicative ((<$>), (<*>), pure) +import Data.Char +import Data.List +import Data.Maybe +import System.IO +import System.Directory + +idrNamespace :: String +idrNamespace = "__IDR__" +idrRTNamespace = "__IDRRT__" +idrLTNamespace = "__IDRLT__" + + +data JSTarget = Node | JavaScript deriving Eq + + +data JSType = JSIntTy + | JSStringTy + | JSIntegerTy + | JSFloatTy + | JSCharTy + | JSPtrTy + | JSForgotTy + deriving Eq + + +data JSInteger = JSBigZero + | JSBigOne + | JSBigInt Integer + deriving Eq + + +data JSNum = JSInt Int + | JSFloat Double + | JSInteger JSInteger + deriving Eq + + +data JS = JSRaw String + | JSIdent String + | JSFunction [String] JS + | JSType JSType + | JSSeq [JS] + | JSReturn JS + | JSApp JS [JS] + | JSNew String [JS] + | JSError String + | JSBinOp String JS JS + | JSPreOp String JS + | JSPostOp String JS + | JSProj JS String + | JSVar LVar + | JSNull + | JSThis + | JSTrue + | JSFalse + | JSArray [JS] + | JSString String + | JSChar String + | JSNum JSNum + | JSAssign JS JS + | JSAlloc String (Maybe JS) + | JSIndex JS JS + | JSCond [(JS, JS)] + | JSTernary JS JS JS + | JSParens JS + | JSWhile JS JS + deriving Eq + + +compileJS :: JS -> String +compileJS (JSRaw code) = + code + +compileJS (JSIdent ident) = + ident + +compileJS (JSFunction args body) = + "function(" + ++ intercalate "," args + ++ "){\n" + ++ compileJS body + ++ "\n}" + +compileJS (JSType ty) + | JSIntTy <- ty = idrRTNamespace ++ "Int" + | JSStringTy <- ty = idrRTNamespace ++ "String" + | JSIntegerTy <- ty = idrRTNamespace ++ "Integer" + | JSFloatTy <- ty = idrRTNamespace ++ "Float" + | JSCharTy <- ty = idrRTNamespace ++ "Char" + | JSPtrTy <- ty = idrRTNamespace ++ "Ptr" + | JSForgotTy <- ty = idrRTNamespace ++ "Forgot" + +compileJS (JSSeq seq) = + intercalate ";\n" (map compileJS seq) + +compileJS (JSReturn val) = + "return " ++ compileJS val + +compileJS (JSApp lhs rhs) + | JSFunction {} <- lhs = + concat ["(", compileJS lhs, ")(", args, ")"] + | otherwise = + concat [compileJS lhs, "(", args, ")"] + where args :: String + args = intercalate "," $ map compileJS rhs + +compileJS (JSNew name args) = + "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")" + +compileJS (JSError exc) = + "throw new Error(\"" ++ exc ++ "\")" + +compileJS (JSBinOp op lhs rhs) = + compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs + +compileJS (JSProj obj field) + | JSFunction {} <- obj = + concat ["(", compileJS obj, ").", field] + | JSAssign {} <- obj = + concat ["(", compileJS obj, ").", field] + | otherwise = + compileJS obj ++ '.' : field + +compileJS (JSVar var) = + translateVariableName var + +compileJS JSNull = + "null" + +compileJS JSThis = + "this" + +compileJS JSTrue = + "true" + +compileJS JSFalse = + "false" + +compileJS (JSArray elems) = + "[" ++ intercalate "," (map compileJS elems) ++ "]" + +compileJS (JSString str) = + show str + +compileJS (JSChar chr) = + chr + +compileJS (JSNum num) + | JSInt i <- num = show i + | JSFloat f <- num = show f + | JSInteger JSBigZero <- num = "__IDRRT__ZERO" + | JSInteger JSBigOne <- num = "__IDRRT__ONE" + | JSInteger (JSBigInt i) <- num = show i + +compileJS (JSAssign lhs rhs) = + compileJS lhs ++ "=" ++ compileJS rhs + +compileJS (JSAlloc name val) = + "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val + +compileJS (JSIndex lhs rhs) = + compileJS lhs ++ "[" ++ compileJS rhs ++ "]" + +compileJS (JSCond branches) = + intercalate " else " $ map createIfBlock branches + where + createIfBlock (JSTrue, e) = + "{\n" + ++ compileJS e + ++ ";\n}" + createIfBlock (cond, e) = + "if (" ++ compileJS cond ++") {\n" + ++ compileJS e + ++ ";\n}" + +compileJS (JSTernary cond true false) = + let c = compileJS cond + t = compileJS true + f = compileJS false in + "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")" + +compileJS (JSParens js) = + "(" ++ compileJS js ++ ")" + +compileJS (JSWhile cond body) = + "while (" ++ compileJS cond ++ ") {\n" + ++ compileJS body + ++ "\n}" + +jsTailcall :: JS -> JS +jsTailcall call = + jsCall (idrRTNamespace ++ "tailcall") [ + JSFunction [] (JSReturn call) + ] + + +jsCall :: String -> [JS] -> JS +jsCall fun = JSApp (JSIdent fun) + + +jsMeth :: JS -> String -> [JS] -> JS +jsMeth obj meth = + JSApp (JSProj obj meth) + + +jsInstanceOf :: JS -> JS -> JS +jsInstanceOf = JSBinOp "instanceof" + + +jsEq :: JS -> JS -> JS +jsEq = JSBinOp "==" + + +jsAnd :: JS -> JS -> JS +jsAnd = JSBinOp "&&" + + +jsType :: JS +jsType = JSIdent $ idrRTNamespace ++ "Type" + + +jsCon :: JS +jsCon = JSIdent $ idrRTNamespace ++ "Con" + + +jsTag :: JS -> JS +jsTag obj = JSProj obj "tag" + + +jsTypeTag :: JS -> JS +jsTypeTag obj = JSProj obj "type" + + +jsBigInt :: JS -> JS +jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero +jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne +jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val] + + +jsVar :: Int -> String +jsVar = ("__var_" ++) . show + + +jsLet :: String -> JS -> JS -> JS +jsLet name value body = + JSApp ( + JSFunction [name] ( + JSReturn body + ) + ) [value] + + +jsError :: String -> JS +jsError err = JSApp (JSFunction [] (JSError err)) [] + + +foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a +foldJS tr add acc js = + fold js + where + fold js + | JSFunction args body <- js = + add (tr js) (fold body) + | JSSeq seq <- js = + add (tr js) $ foldl' add acc (map fold seq) + | JSReturn ret <- js = + add (tr js) (fold ret) + | JSApp lhs rhs <- js = + add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs) + | JSNew _ args <- js = + add (tr js) $ foldl' add acc $ map fold args + | JSBinOp _ lhs rhs <- js = + add (tr js) $ add (fold lhs) (fold rhs) + | JSPreOp _ val <- js = + add (tr js) $ fold val + | JSPostOp _ val <- js = + add (tr js) $ fold val + | JSProj obj _ <- js = + add (tr js) (fold obj) + | JSArray vals <- js = + add (tr js) $ foldl' add acc $ map fold vals + | JSAssign lhs rhs <- js = + add (tr js) $ add (fold lhs) (fold rhs) + | JSIndex lhs rhs <- js = + add (tr js) $ add (fold lhs) (fold rhs) + | JSAlloc _ val <- js = + add (tr js) $ fromMaybe acc $ fmap fold val + | JSTernary c t f <- js = + add (tr js) $ add (fold c) (add (fold t) (fold f)) + | JSParens val <- js = + add (tr js) $ fold val + | JSCond conds <- js = + add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds + | JSWhile cond body <- js = + add (tr js) $ add (fold cond) (fold body) + | otherwise = + tr js + + +transformJS :: (JS -> JS) -> JS -> JS +transformJS tr js = + transformHelper js + where + transformHelper :: JS -> JS + transformHelper js + | JSFunction args body <- js = JSFunction args $ tr body + | JSSeq seq <- js = JSSeq $ map tr seq + | JSReturn ret <- js = JSReturn $ tr ret + | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs + | JSNew con args <- js = JSNew con $ map tr args + | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs) + | JSPreOp op val <- js = JSPreOp op (tr val) + | JSPostOp op val <- js = JSPostOp op (tr val) + | JSProj obj field <- js = JSProj (tr obj) field + | JSArray vals <- js = JSArray $ map tr vals + | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs) + | JSAlloc var val <- js = JSAlloc var $ fmap tr val + | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs) + | JSCond conds <- js = JSCond $ map (tr *** tr) conds + | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f) + | JSParens val <- js = JSParens $ tr val + | JSWhile cond body <- js = JSWhile(tr cond) (tr body) + | otherwise = js + + +moveJSDeclToTop :: String -> [JS] -> [JS] +moveJSDeclToTop decl js = move ([], js) + where + move :: ([JS], [JS]) -> [JS] + move (front, js@(JSAlloc name _):back) + | name == decl = js : front ++ back + + move (front, js:back) = + move (front ++ [js], back) + + +jsSubst :: JS -> JS -> JS -> JS +jsSubst var new old + | var == old = new + +jsSubst (JSIdent var) new (JSVar old) + | var == translateVariableName old = new + | otherwise = JSVar old + +jsSubst var new old@(JSIdent _) + | var == old = new + | otherwise = old + +jsSubst var new (JSArray fields) = + JSArray (map (jsSubst var new) fields) + +jsSubst var new (JSNew con vals) = + JSNew con $ map (jsSubst var new) vals + +jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals) + | var `notElem` args = + JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") ( + map (jsSubst (JSIdent var) new) vals + ) + | otherwise = + JSApp (JSProj (JSFunction args body) "apply") ( + map (jsSubst (JSIdent var) new) vals + ) + +jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals) + | var /= arg = + JSApp (JSFunction [arg] ( + jsSubst (JSIdent var) new body + )) $ map (jsSubst (JSIdent var) new) vals + | otherwise = + JSApp (JSFunction [arg] ( + body + )) $ map (jsSubst (JSIdent var) new) vals + +jsSubst var new js = transformJS (jsSubst var new) js + + +removeAllocations :: JS -> JS +removeAllocations (JSSeq body) = + let opt = removeHelper (map removeAllocations body) in + case opt of + [ret] -> ret + _ -> JSSeq opt + where + removeHelper :: [JS] -> [JS] + removeHelper [js] = [js] + removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) = + map (jsSubst (JSIdent name) val) (removeHelper js) + removeHelper (j:js) = j : removeHelper js + +removeAllocations js = transformJS removeAllocations js + + +isJSConstant :: JS -> Bool +isJSConstant js + | JSString _ <- js = True + | JSChar _ <- js = True + | JSNum _ <- js = True + | JSType _ <- js = True + | JSNull <- js = True + + | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True + | otherwise = False + + +inlineJS :: JS -> JS +inlineJS (JSReturn (JSApp (JSFunction [] err@(JSError _)) [])) = err +inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) = + inlineJS $ jsSubst (JSIdent "cse") val body + + +inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) = + inlineJS $ JSSeq [ JSAlloc arg (Just val) + , cond + ] + +inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [ + JSThis,JSProj var "vars" + ]) + | var /= JSIdent "cse" = + inlineJS $ inlineApply args body 0 + where + inlineApply [] body _ = inlineJS body + inlineApply (a:as) body n = + inlineApply as ( + jsSubst (JSIdent a) (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body + ) (n + 1) + +inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val]) + | isJSConstant val = val + +inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [ + JSFunction [] (JSReturn val) + ]) + | isJSConstant val = val + +inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val]) + | JSNew con [tag, vals] <- ret + , opt <- inlineJS val = + inlineJS $ JSNew con [tag, inlineJS $ jsSubst (JSIdent arg) opt vals] + + | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret + , opt <- inlineJS val = + inlineJS $ JSNew con [JSFunction [] ( + JSReturn ( + JSApp ( + inlineJS $ jsSubst (JSIdent arg) opt fun + ) ( + map (inlineJS . jsSubst (JSIdent arg) opt) vars + ) + ) + )] + + | JSApp (JSProj obj field) args <- ret + , opt <- inlineJS val = + inlineJS $ JSApp ( + inlineJS $ JSProj (jsSubst (JSIdent arg) opt obj) field + ) ( + map (inlineJS . jsSubst (JSIdent arg) opt) args + ) + + | JSIndex (JSProj obj field) idx <- ret + , opt <- inlineJS val = + inlineJS $ JSIndex (JSProj ( + inlineJS $ jsSubst (JSIdent arg) opt obj + ) field + ) (inlineJS $ jsSubst (JSIdent arg) opt idx) + + | JSBinOp op lhs rhs <- ret + , opt <- inlineJS val = + inlineJS $ JSBinOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $ + (inlineJS $ jsSubst (JSIdent arg) opt rhs) + + | JSApp (JSIdent fun) args <- ret + , opt <- inlineJS val = + inlineJS $ JSApp (JSIdent fun) $ map (inlineJS . jsSubst (JSIdent arg) opt) args + +inlineJS js = transformJS inlineJS js + + +reduceJS :: [JS] -> [JS] +reduceJS js = reduceLoop [] ([], js) + + +funName :: JS -> String +funName (JSAlloc fun _) = fun + + +elimDeadLoop :: [JS] -> [JS] +elimDeadLoop js + | ret <- deadEvalApplyCases js + , ret /= js = elimDeadLoop ret + | otherwise = js + + +deadEvalApplyCases :: [JS] -> [JS] +deadEvalApplyCases js = + let tags = sort $ nub $ concatMap (getTags) js in + map (removeHelper tags) js + where + getTags :: JS -> [Int] + getTags = foldJS match (++) [] + where + match js + | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag] + | otherwise = [] + + + removeHelper :: [Int] -> JS -> JS + removeHelper tags (JSAlloc fun (Just ( + JSApp (JSFunction [] (JSSeq seq)) [])) + ) = + (JSAlloc fun (Just ( + JSApp (JSFunction [] (JSSeq $ remover tags seq)) [])) + ) + + removeHelper _ js = js + + + remover :: [Int] -> [JS] -> [JS] + remover tags ( + j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js + ) + | tag `notElem` tags = remover tags js + + remover tags (j:js) = j : remover tags js + remover _ [] = [] + + +initConstructors :: [JS] -> [JS] +initConstructors js = + let tags = nub $ sort $ concat (map getTags js) in + rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js + where + rearrangePrelude :: [JS] -> [JS] + rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con" + + + getTags :: JS -> [Int] + getTags = foldJS match (++) [] + where + match js + | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag] + | otherwise = [] + + + replaceConstructors :: [Int] -> [JS] -> [JS] + replaceConstructors tags js = map (replaceHelper tags) js + where + replaceHelper :: [Int] -> JS -> JS + replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []]) + | tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag) + + replaceHelper tags js = transformJS (replaceHelper tags) js + + + createConstant :: Int -> JS + createConstant tag = + JSAlloc ("__IDRCTR__" ++ show tag) (Just ( + JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []] + )) + + +removeIDs :: [JS] -> [JS] +removeIDs js = + case partition isID js of + ([], rest) -> rest + (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest + where isID :: JS -> Bool + isID (JSAlloc _ (Just (JSFunction _ (JSSeq body)))) + | JSReturn (JSVar _) <- last body = True + + isID _ = False + + + idFor :: JS -> (String, Int) + idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) + | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos) + + + removeIDCall :: [(String, Int)] -> JS -> JS + removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( + JSReturn (JSApp (JSIdent fun) args) + )]) + | Just pos <- lookup fun ids + , pos < length args = args !! pos + + removeIDCall ids (JSNew _ [JSFunction [] ( + JSReturn (JSApp (JSIdent fun) args) + )]) + | Just pos <- lookup fun ids + , pos < length args = args !! pos + + removeIDCall ids js@(JSApp id@(JSIdent fun) args) + | Just pos <- lookup fun ids + , pos < length args = args !! pos + + removeIDCall ids js = transformJS (removeIDCall ids) js + + +inlineFunctions :: [JS] -> [JS] +inlineFunctions js = + inlineHelper ([], js) + where + inlineHelper :: ([JS], [JS]) -> [JS] + inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back) + | countAll fun front + countAll fun back == 0 = + inlineHelper (front, back) + | Just new <- inlineAble ( + countAll fun front + countAll fun back + ) fun args body = + let f = map (inline fun args new) in + inlineHelper (f front, f back) + + inlineHelper (front, next:back) = inlineHelper (front ++ [next], back) + inlineHelper (front, []) = front + + + inlineAble :: Int -> String -> [String] -> JS -> Maybe JS + inlineAble 1 fun args body + | nonRecur fun body = + inlineAble' body + where + inlineAble' :: JS -> Maybe JS + inlineAble' ( + JSReturn js@(JSNew "__IDRRT__Con" [JSNum _, JSArray vals]) + ) + | and $ map (\x -> isJSIdent x || isJSConstant x) vals = Just js + + inlineAble' ( + JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] ( + JSReturn (JSApp (JSIdent _) args) + )]) + ) + | and $ map (\x -> isJSIdent x || isJSConstant x) args = Just js + + inlineAble' ( + JSReturn js@(JSIndex (JSProj (JSApp (JSIdent _) args) "vars") _) + ) + | and $ map (\x -> isJSIdent x || isJSConstant x) args = Just js + + inlineAble' _ = Nothing + + isJSIdent js + | JSIdent _ <- js = True + | otherwise = False + + inlineAble _ _ _ _ = Nothing + + + inline :: String -> [String] -> JS -> JS -> JS + inline fun args body js = inline' js + where + inline' :: JS -> JS + inline' (JSApp (JSIdent name) vals) + | name == fun = + let (js, phs) = insertPlaceHolders args body in + inline' $ foldr (uncurry jsSubst) js (zip phs vals) + + inline' js = transformJS inline' js + + insertPlaceHolders :: [String] -> JS -> (JS, [JS]) + insertPlaceHolders args body = insertPlaceHolders' args body [] + where + insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS]) + insertPlaceHolders' (a:as) body ph + | (body', ph') <- insertPlaceHolders' as body ph = + let phvar = JSIdent $ "__PH_" ++ show (length ph') in + (jsSubst (JSIdent a) phvar body', phvar : ph') + + insertPlaceHolders' [] body ph = (body, ph) + + + nonRecur :: String -> JS -> Bool + nonRecur name body = countInvokations name body == 0 + + + countAll :: String -> [JS] -> Int + countAll name js = sum $ map (countInvokations name) js + + + countInvokations :: String -> JS -> Int + countInvokations name = foldJS match (+) 0 + where + match :: JS -> Int + match js + | JSApp (JSIdent ident) _ <- js + , name == ident = 1 + | JSNew con _ <- js + , name == con = 1 + | otherwise = 0 + + +reduceContinuations :: JS -> JS +reduceContinuations = transformJS reduceHelper + where + reduceHelper :: JS -> JS + reduceHelper (JSNew "__IDRRT__Cont" [JSFunction [] ( + JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body]) + )]) = js + + reduceHelper js = transformJS reduceHelper js + + +reduceConstant :: JS -> JS +reduceConstant + (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( + JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val]) + )]) + | JSNum num <- val = val + | JSBinOp op lhs rhs <- val = + JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs) + + | JSApp (JSProj lhs op) [rhs] <- val + , op `elem` [ "subtract" + , "add" + , "multiply" + , "divide" + , "mod" + , "equals" + , "lesser" + , "lesserOrEquals" + , "greater" + , "greaterOrEquals" + ] = val + +reduceConstant (JSApp ident [(JSParens js)]) = + JSApp ident [reduceConstant js] + +reduceConstant js = transformJS reduceConstant js + + +reduceConstants :: JS -> JS +reduceConstants js + | ret <- reduceConstant js + , ret /= js = reduceConstants ret + | otherwise = js + + +elimDuplicateEvals :: JS -> JS +elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) = + JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq)) + where + elimHelper :: [JS] -> [JS] + elimHelper (j@(JSAlloc var (Just val)):js) = + j : map (jsSubst val (JSIdent var)) (elimHelper js) + elimHelper (j:js) = + j : elimHelper js + elimHelper [] = [] + +elimDuplicateEvals js = js + + +optimizeRuntimeCalls :: String -> String -> [JS] -> [JS] +optimizeRuntimeCalls fun tc js = + optTC tc : map optHelper js + where + optHelper :: JS -> JS + optHelper (JSApp (JSIdent "__IDRRT__tailcall") [ + JSFunction [] (JSReturn (JSApp (JSIdent n) args)) + ]) + | n == fun = JSApp (JSIdent tc) $ map optHelper args + + optHelper js = transformJS optHelper js + + + optTC :: String -> JS + optTC tc@"__IDRRT__EVALTC" = + JSAlloc tc (Just $ JSFunction ["arg0"] ( + JSSeq [ JSAlloc "ret" $ Just ( + JSTernary ( + (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd` + (hasProp "__IDRLT__mEVAL0" "arg0") + ) (JSApp + (JSIndex + (JSIdent "__IDRLT__mEVAL0") + (JSProj (JSIdent "arg0") "tag") + ) + [JSIdent "arg0"] + ) (JSIdent "arg0") + ) + , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) ( + JSAssign (JSIdent "ret") ( + JSApp (JSProj (JSIdent "ret") "k") [] + ) + ) + , JSReturn $ JSIdent "ret" + ] + )) + + optTC tc@"__IDRRT__APPLYTC" = + JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] ( + JSSeq [ JSAlloc "ev" $ Just (JSApp + (JSIdent "__IDRRT__EVALTC") [JSIdent "fn0"] + ) + , JSAlloc "ret" $ Just ( + JSTernary ( + (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd` + (hasProp "__IDRLT__mAPPLY0" "ev") + ) (JSApp + (JSIndex + (JSIdent "__IDRLT__mAPPLY0") + (JSProj (JSIdent "ev") "tag") + ) + [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"] + ) JSNull + ) + , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) ( + JSAssign (JSIdent "ret") ( + JSApp (JSProj (JSIdent "ret") "k") [] + ) + ) + , JSReturn $ JSIdent "ret" + ] + )) + + + hasProp :: String -> String -> JS + hasProp table var = + JSIndex (JSIdent table) (JSProj (JSIdent var) "tag") + + +unfoldLookupTable :: [JS] -> [JS] +unfoldLookupTable input = + let (evals, evalunfold) = unfoldLT "__IDRLT__mEVAL0" input + (applys, applyunfold) = unfoldLT "__IDRLT__mAPPLY0" evalunfold + js = applyunfold in + adaptRuntime $ expandCons evals applys js + where + adaptRuntime :: [JS] -> [JS] + adaptRuntime = + adaptCon . adaptApply "__var_2" . adaptApply "ev" . adaptEval + + + adaptApply var = map (jsSubst ( + JSIndex (JSIdent "__IDRLT__mAPPLY0") (JSProj (JSIdent var) "tag") + ) (JSProj (JSIdent var) "app")) + + + adaptEval = map (jsSubst ( + JSIndex (JSIdent "__IDRLT__mEVAL0") (JSProj (JSIdent "arg0") "tag") + ) (JSProj (JSIdent "arg0") "eval")) + + + adaptCon js = + adaptCon' [] js + where + adaptCon' front ((JSAlloc "__IDRRT__Con" (Just body)):back) = + front ++ (new:back) + + adaptCon' front (next:back) = + adaptCon' (front ++ [next]) back + + adaptCon' front [] = front + + + new = + JSAlloc "__IDRRT__Con" (Just $ + JSFunction newArgs ( + JSSeq (map newVar newArgs) + ) + ) + where + newVar var = JSAssign (JSProj JSThis var) (JSIdent var) + newArgs = ["tag", "eval", "app", "vars"] + + + unfoldLT :: String -> [JS] -> ([Int], [JS]) + unfoldLT lt js = + let (table, code) = extractLT lt js + expanded = expandLT lt table in + (map fst expanded, map snd expanded ++ code) + + + expandCons :: [Int] -> [Int] -> [JS] -> [JS] + expandCons evals applys js = + map expandCons' js + where + expandCons' :: JS -> JS + expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args]) + | evalid <- getId "__IDRLT__mEVAL0" tag evals + , applyid <- getId "__IDRLT__mAPPLY0" tag applys = + JSNew "__IDRRT__Con" [ JSNum (JSInt tag) + , maybe JSNull JSIdent evalid + , maybe JSNull JSIdent applyid + , JSArray (map expandCons' args) + ] + + expandCons' js = transformJS expandCons' js + + + getId :: String -> Int -> [Int] -> Maybe String + getId lt tag entries + | tag `elem` entries = Just $ ltIdentifier lt tag + | otherwise = Nothing + + + ltIdentifier :: String -> Int -> String + ltIdentifier "__IDRLT__mEVAL0" id = idrLTNamespace ++ "EVAL" ++ show id + ltIdentifier "__IDRLT__mAPPLY0" id = idrLTNamespace ++ "APPLY" ++ show id + + + extractLT :: String -> [JS] -> (JS, [JS]) + extractLT lt js = + extractLT' ([], js) + where + extractLT' :: ([JS], [JS]) -> (JS, [JS]) + extractLT' (front, js@(JSAlloc fun _):back) + | fun == lt = (js, front ++ back) + + extractLT' (front, js:back) = extractLT' (front ++ [js], back) + + + expandLT :: String -> JS -> [(Int, JS)] + expandLT lt ( + JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) [])) + ) = catMaybes (map expandEntry seq) + where + expandEntry :: JS -> Maybe (Int, JS) + expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) = + Just $ (id, JSAlloc (ltIdentifier lt id) (Just body)) + + expandEntry js = Nothing + + +removeInstanceChecks :: JS -> JS +removeInstanceChecks (JSCond conds) = + JSCond $ eliminateDeadBranches $ map ( + removeHelper *** removeInstanceChecks + ) conds + where + removeHelper ( + JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check + ) = removeHelper check + removeHelper js = js + + + eliminateDeadBranches (e@(JSTrue, _):_) = [e] + eliminateDeadBranches [(_, js)] = [(JSTrue, js)] + eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs + eliminateDeadBranches [] = [] + +removeInstanceChecks js = transformJS removeInstanceChecks js + + +reduceLoop :: [String] -> ([JS], [JS]) -> [JS] +reduceLoop reduced (cons, program) = + case partition findConstructors program of + ([], js) -> cons ++ js + (candidates, rest) -> + let names = reduced ++ map funName candidates in + reduceLoop names ( + cons ++ map reduce candidates, map (reduceCall names) rest + ) + where findConstructors :: JS -> Bool + findConstructors js + | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js = + reducable $ last body + | otherwise = False + where reducable :: JS -> Bool + reducable js + | JSReturn ret <- js = reducable ret + | JSNew _ args <- js = and $ map reducable args + | JSArray fields <- js = and $ map reducable fields + | JSNum _ <- js = True + | JSNull <- js = True + | JSIdent _ <- js = True + | otherwise = False + + + reduce :: JS -> JS + reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) + | JSReturn js <- last body = (JSAlloc fun (Just js)) + + reduce js = js + + + reduceCall :: [String] -> JS -> JS + reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( + JSReturn (JSApp id@(JSIdent ret) _) + )]) + | ret `elem` funs = id + + reduceCall funs js@(JSApp id@(JSIdent fun) _) + | fun `elem` funs = id + + reduceCall funs js = transformJS (reduceCall funs) js + + +optimizeJS :: JS -> JS +optimizeJS = inlineLoop + where inlineLoop :: JS -> JS + inlineLoop js + | opt <- inlineJS js + , opt /= js = inlineLoop opt + | otherwise = js + + +codegenJavaScript + :: JSTarget + -> [(Name, SDecl)] + -> FilePath + -> OutputType + -> IO () +codegenJavaScript target definitions filename outputType = do + let (header, runtime) = case target of + Node -> + ("#!/usr/bin/env node\n", "-node") + JavaScript -> + ("", "-browser") + path <- (++) <$> getDataDir <*> (pure "/jsrts/") + idrRuntime <- readFile $ path ++ "Runtime-common.js" + tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"] + jsbn <- readFile $ path ++ "jsbn/jsbn.js" + writeFile filename $ header ++ ( + intercalate "\n" $ [ jsbn + , idrRuntime + , tgtRuntime + ] ++ functions + ) + + setPermissions filename (emptyPermissions { readable = True + , executable = target == Node + , writable = True + }) + where + def :: [(String, SDecl)] + def = map (first translateNamespace) definitions + + + functions :: [String] + functions = translate >>> optimize >>> compile $ def + where + translate p = + prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop] + optimize p = + foldl' (flip ($)) p opt + compile = + map compileJS + + opt = + [ map optimizeJS + , removeIDs + , reduceJS + , map reduceConstants + , initConstructors + , map removeAllocations + , elimDeadLoop + , map elimDuplicateEvals + , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC" + , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC" + , map removeInstanceChecks + , inlineFunctions + , map reduceContinuations + , unfoldLookupTable + ] + + prelude :: [JS] + prelude = + [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] ( + JSAssign (JSProj JSThis "k") (JSIdent "k") + )) + , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] ( + JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag") + , JSAssign (JSProj JSThis "vars") (JSIdent "vars") + ] + )) + ] + + mainLoop :: JS + mainLoop = + JSAlloc "main" $ Just $ JSFunction [] ( + case target of + Node -> mainFun + JavaScript -> jsMeth (JSIdent "window") "addEventListener" [ + JSString "DOMContentLoaded", JSFunction [] ( + mainFun + ), JSFalse + ] + ) + where + mainFun :: JS + mainFun = jsTailcall $ jsCall runMain [] + + + runMain :: String + runMain = idrNamespace ++ translateName (sMN 0 "runMain") + + + invokeLoop :: JS + invokeLoop = jsCall "main" [] + + +translateIdentifier :: String -> String +translateIdentifier = + replaceReserved . concatMap replaceBadChars + where replaceBadChars :: Char -> String + replaceBadChars c + | ' ' <- c = "_" + | '_' <- c = "__" + | isDigit c = '_' : show (ord c) + | not (isLetter c && isAscii c) = '_' : show (ord c) + | otherwise = [c] + replaceReserved s + | s `elem` reserved = '_' : s + | otherwise = s + + + reserved = [ "break" + , "case" + , "catch" + , "continue" + , "debugger" + , "default" + , "delete" + , "do" + , "else" + , "finally" + , "for" + , "function" + , "if" + , "in" + , "instanceof" + , "new" + , "return" + , "switch" + , "this" + , "throw" + , "try" + , "typeof" + , "var" + , "void" + , "while" + , "with" + + , "class" + , "enum" + , "export" + , "extends" + , "import" + , "super" + + , "implements" + , "interface" + , "let" + , "package" + , "private" + , "protected" + , "public" + , "static" + , "yield" + ] + + +translateNamespace :: Name -> String +translateNamespace (UN _) = idrNamespace +translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns +translateNamespace (MN _ _) = idrNamespace +translateNamespace (SN name) = idrNamespace ++ translateSpecialName name +translateNamespace NErased = idrNamespace + + +translateName :: Name -> String +translateName (UN name) = 'u' : translateIdentifier (str name) +translateName (NS name _) = 'n' : translateName name +translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i +translateName (SN name) = 's' : translateSpecialName name +translateName NErased = "e" + + +translateSpecialName :: SpecialName -> String +translateSpecialName name + | WhereN i m n <- name = + 'w' : translateName m ++ translateName n ++ show i + | InstanceN n s <- name = + 'i' : translateName n ++ concatMap (translateIdentifier . str) s + | ParentN n s <- name = + 'p' : translateName n ++ translateIdentifier (str s) + | MethodN n <- name = + 'm' : translateName n + | CaseN n <- name = + 'c' : translateName n + + +translateConstant :: Const -> JS +translateConstant (I i) = JSNum (JSInt i) +translateConstant (Fl f) = JSNum (JSFloat f) +translateConstant (Ch '\DEL') = JSChar "'\\u007F'" +translateConstant (Ch '\a') = JSChar "'\\u0007'" +translateConstant (Ch '\SO') = JSChar "'\\u000E'" +translateConstant (Ch c) = JSString [c] +translateConstant (Str s) = JSString s +translateConstant (AType (ATInt ITNative)) = JSType JSIntTy +translateConstant StrType = JSType JSStringTy +translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy +translateConstant (AType ATFloat) = JSType JSFloatTy +translateConstant (AType (ATInt ITChar)) = JSType JSCharTy +translateConstant PtrType = JSType JSPtrTy +translateConstant Forgot = JSType JSForgotTy +translateConstant (BI i) = jsBigInt $ JSString (show i) +translateConstant c = + jsError $ "Unimplemented Constant: " ++ show c + + +translateDeclaration :: (String, SDecl) -> [JS] +translateDeclaration (path, SFun name params stackSize body) + | (MN _ ap) <- name + , (SLet var val next) <- body + , (SChkCase cvar cases) <- next + , ap == txt "APPLY" = + let lvar = translateVariableName var + lookup t = (JSApp + (JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag")) + [JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in + [ lookupTable [(var, "chk")] var cases + , jsDecl $ JSFunction ["fn0", "arg0"] ( + JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0") + , JSAlloc (translateVariableName var) ( + Just $ translateExpression val + ) + , JSReturn $ (JSTernary ( + (JSVar var `jsInstanceOf` jsCon) `jsAnd` + (hasProp lookupTableName (translateVariableName var)) + ) (lookup lookupTableName) JSNull) + ] + ) + ] + + | (MN _ ev) <- name + , (SChkCase var cases) <- body + , ev == txt "EVAL" = + [ lookupTable [] var cases + , jsDecl $ JSFunction ["arg0"] (JSReturn $ + JSTernary ( + (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd` + (hasProp lookupTableName "arg0") + ) (JSApp + (JSIndex (JSIdent lookupTableName) (JSProj (JSIdent "arg0") "tag")) + [JSIdent "arg0"] + ) (JSIdent "arg0") + ) + ] + | otherwise = + let fun = translateExpression body in + [jsDecl $ jsFun fun] + + where + hasProp :: String -> String -> JS + hasProp table var = + JSIndex (JSIdent table) (JSProj (JSIdent var) "tag") + + + caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS + caseFun aux var cse = + let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in + jsFunAux aux c + + + getTag :: SAlt -> Maybe Int + getTag (SConCase _ tag _ _ _) = Just tag + getTag _ = Nothing + + + lookupTableName :: String + lookupTableName = idrLTNamespace ++ translateName name + + + lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS + lookupTable aux var cases = + JSAlloc lookupTableName $ Just ( + JSApp (JSFunction [] ( + JSSeq $ [ + JSAlloc "t" $ Just (JSArray []) + ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [ + JSReturn (JSIdent "t") + ] + )) [] + ) + where + assignEntries :: [(Int, JS)] -> [JS] + assignEntries entries = + map (\(tag, fun) -> + JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun + ) entries + + + lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS) + lookupEntry aux var alt = do + tag <- getTag alt + return (tag, caseFun aux var alt) + + + jsDecl :: JS -> JS + jsDecl = JSAlloc (path ++ translateName name) . Just + + + jsFun body = jsFunAux [] body + + + jsFunAux :: [(LVar, String)] -> JS -> JS + jsFunAux aux body = + JSFunction (p ++ map snd aux) ( + JSSeq $ + zipWith assignVar [0..] p ++ + map assignAux aux ++ + [JSReturn body] + ) + where + assignVar :: Int -> String -> JS + assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s) + + + assignAux :: (LVar, String) -> JS + assignAux (Loc var, val) = + JSAlloc (jsVar var) (Just $ JSIdent val) + + + p :: [String] + p = map translateName params + + +translateVariableName :: LVar -> String +translateVariableName (Loc i) = + jsVar i + + +translateExpression :: SExp -> JS +translateExpression (SLet name value body) = + jsLet (translateVariableName name) ( + translateExpression value + ) (translateExpression body) + +translateExpression (SConst cst) = + translateConstant cst + +translateExpression (SV var) = + JSVar var + +translateExpression (SApp tc name vars) + | False <- tc = + jsTailcall $ translateFunctionCall name vars + | True <- tc = + JSNew (idrRTNamespace ++ "Cont") [JSFunction [] ( + JSReturn $ translateFunctionCall name vars + )] + where + translateFunctionCall name vars = + jsCall (translateNamespace name ++ translateName name) (map JSVar vars) + +translateExpression (SOp op vars) + | LNoOp <- op = JSVar (last vars) + + | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)] + | (LPlus (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs] + | (LMinus (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs] + | (LTimes (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs] + | (LSDiv (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs] + | (LSRem (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs] + | (LEq (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs] + | (LSLt (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs] + | (LSLe (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs] + | (LSGt (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs] + | (LSGe (ATInt ITBig)) <- op + , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs] + + | (LPlus ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs + | (LMinus ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs + | (LTimes ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs + | (LSDiv ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs + | (LEq ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs + | (LSLt ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs + | (LSLe ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs + | (LSGt ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs + | (LSGe ATFloat) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs + + | (LPlus _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs + | (LMinus _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs + | (LTimes _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs + | (LSDiv _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs + | (LSRem _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs + | (LEq _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs + | (LSLt _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs + | (LSLe _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs + | (LSGt _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs + | (LSGe _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs + | (LAnd _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs + | (LOr _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs + | (LXOr _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs + | (LSHL _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs + | (LASHR _) <- op + , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs + | (LCompl _) <- op + , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg + + | LStrConcat <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs + | LStrEq <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs + | LStrLt <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs + | LStrLen <- op + , (arg:_) <- vars = JSProj (JSVar arg) "length" + + | (LStrInt ITNative) <- op + , (arg:_) <- vars = jsCall "parseInt" [JSVar arg] + | (LIntStr ITNative) <- op + , (arg:_) <- vars = jsCall "String" [JSVar arg] + | (LSExt ITNative ITBig) <- op + , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg] + | (LTrunc ITBig ITNative) <- op + , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" [] + | (LIntStr ITBig) <- op + , (arg:_) <- vars = jsMeth (JSVar arg) "toString" [] + | (LStrInt ITBig) <- op + , (arg:_) <- vars = jsBigInt $ JSVar arg + | LFloatStr <- op + , (arg:_) <- vars = jsCall "String" [JSVar arg] + | LStrFloat <- op + , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg] + | (LIntFloat ITNative) <- op + , (arg:_) <- vars = JSVar arg + | (LFloatInt ITNative) <- op + , (arg:_) <- vars = JSVar arg + | (LChInt ITNative) <- op + , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)" + | (LIntCh ITNative) <- op + , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg] + + | LFExp <- op + , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg] + | LFLog <- op + , (arg:_) <- vars = jsCall "Math.log" [JSVar arg] + | LFSin <- op + , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg] + | LFCos <- op + , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg] + | LFTan <- op + , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg] + | LFASin <- op + , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg] + | LFACos <- op + , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg] + | LFATan <- op + , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg] + | LFSqrt <- op + , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg] + | LFFloor <- op + , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg] + | LFCeil <- op + , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg] + + | LStrCons <- op + , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs + | LStrHead <- op + , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0)) + | LStrRev <- op + , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')" + | LStrIndex <- op + , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs) + | LStrTail <- op + , (arg:_) <- vars = let v = translateVariableName arg in + JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)" + | LNullPtr <- op + , (_) <- vars = JSNull + + where + translateBinaryOp :: String -> LVar -> LVar -> JS + translateBinaryOp f lhs rhs = JSBinOp f (JSVar lhs) (JSVar rhs) + + + invokeMeth :: LVar -> String -> [LVar] -> JS + invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args) + +translateExpression (SError msg) = + jsError msg + +translateExpression (SForeign _ _ "putStr" [(FString, var)]) = + jsCall (idrRTNamespace ++ "print") [JSVar var] + +translateExpression (SForeign _ _ fun args) = + ffi fun (map generateWrapper args) + where + generateWrapper (ffunc, name) + | FFunction <- ffunc = + idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")" + | FFunctionIO <- ffunc = + idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")" + + generateWrapper (_, name) = + translateVariableName name + +translateExpression patterncase + | (SChkCase var cases) <- patterncase = caseHelper var cases "chk" + | (SCase var cases) <- patterncase = caseHelper var cases "cse" + where + caseHelper var cases param = + JSApp (JSFunction [param] ( + JSCond $ map (expandCase param . translateCaseCond param) cases + )) [JSVar var] + + + expandCase :: String -> (Cond, JS) -> (JS, JS) + expandCase _ (RawCond cond, branch) = (cond, branch) + expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch) + expandCase var (CaseCond caseTy, branch) + | ConCase tag <- caseTy = + let checkCon = JSIdent var `jsInstanceOf` jsCon + checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in + (checkCon `jsAnd` checkTag, branch) + + | TypeCase ty <- caseTy = + let checkTy = JSIdent var `jsInstanceOf` jsType + checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in + (checkTy `jsAnd` checkTag, branch) + +translateExpression (SCon i name vars) = + JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i + , JSArray $ map JSVar vars + ] + +translateExpression (SUpdate var@(Loc i) e) = + JSAssign (JSVar var) (translateExpression e) + +translateExpression (SProj var i) = + JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i) + +translateExpression SNothing = JSNull + +translateExpression e = + jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e) + + +data FFI = FFICode Char | FFIArg Int | FFIError String + + +ffi :: String -> [String] -> JS +ffi code args = let parsed = ffiParse code in + case ffiError parsed of + Just err -> jsError err + Nothing -> JSRaw $ renderFFI parsed args + where + ffiParse :: String -> [FFI] + ffiParse "" = [] + ffiParse ['%'] = [FFIError "Invalid positional argument"] + ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss + ffiParse ('%':s:ss) + | isDigit s = + FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss) + | otherwise = + [FFIError "Invalid positional argument"] + ffiParse (s:ss) = FFICode s : ffiParse ss + + + ffiError :: [FFI] -> Maybe String + ffiError [] = Nothing + ffiError ((FFIError s):xs) = Just s + ffiError (x:xs) = ffiError xs + + + renderFFI :: [FFI] -> [String] -> String + renderFFI [] _ = "" + renderFFI ((FFICode c) : fs) args = c : renderFFI fs args + renderFFI ((FFIArg i) : fs) args + | i < length args && i >= 0 = args !! i ++ renderFFI fs args + | otherwise = "Argument index out of bounds" + + +data CaseType = ConCase Int + | TypeCase JSType + | DefaultCase + deriving Eq + + +data Cond = CaseCond CaseType + | RawCond JS + + +translateCaseCond :: String -> SAlt -> (Cond, JS) +translateCaseCond _ cse@(SDefaultCase _) = + (CaseCond DefaultCase, translateCase Nothing cse) + +translateCaseCond var cse@(SConstCase ty _) + | StrType <- ty = matchHelper JSStringTy + | PtrType <- ty = matchHelper JSPtrTy + | Forgot <- ty = matchHelper JSForgotTy + | (AType ATFloat) <- ty = matchHelper JSFloatTy + | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy + | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy + | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy + where + matchHelper :: JSType -> (Cond, JS) + matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse) + +translateCaseCond var cse@(SConstCase cst@(BI _) _) = + let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in + (RawCond cond, translateCase Nothing cse) + +translateCaseCond var cse@(SConstCase cst _) = + let cond = JSIdent var `jsEq` translateConstant cst in + (RawCond cond, translateCase Nothing cse) + +translateCaseCond var cse@(SConCase _ tag _ _ _) = + (CaseCond $ ConCase tag, translateCase (Just var) cse) + + +translateCase :: Maybe String -> SAlt -> JS +translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e +translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e +translateCase (Just var) (SConCase a _ _ vars e) = + let params = map jsVar [a .. (a + length vars)] in + JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [ JSThis, JSProj (JSIdent var) "vars" ] diff --git a/src/IRTS/CodegenLLVM.hs b/src/IRTS/CodegenLLVM.hs --- a/src/IRTS/CodegenLLVM.hs +++ b/src/IRTS/CodegenLLVM.hs @@ -4,8 +4,9 @@ import IRTS.CodegenCommon import IRTS.Lang import IRTS.Simplified -import qualified Core.TT as TT -import Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth) +import IRTS.System +import qualified Idris.Core.TT as TT +import Idris.Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth) import Util.System import Paths_idris @@ -1171,6 +1172,8 @@ stdErr <- getStdErr ptr <- inst $ loadInv stdErr box FPtr ptr + +cgOp LNullPtr [] = box FPtr (ConstantOperand $ C.Null (PointerType (IntegerType 8) (AddrSpace 0))) cgOp prim args = ierror $ "Unimplemented primitive: <" ++ show prim ++ ">(" ++ intersperse ',' (take (length args) ['a'..]) ++ ")" diff --git a/src/IRTS/Compiler.hs b/src/IRTS/Compiler.hs --- a/src/IRTS/Compiler.hs +++ b/src/IRTS/Compiler.hs @@ -21,9 +21,9 @@ import Idris.UnusedArgs import Idris.Error -import Core.TT -import Core.Evaluate -import Core.CaseTree +import Idris.Core.TT +import Idris.Core.Evaluate +import Idris.Core.CaseTree import Control.Monad.State import Data.List @@ -40,7 +40,7 @@ = do checkMVs let tmnames = namesUsed (STerm tm) usedIn <- mapM (allNames []) tmnames - let used = [UN "prim__subBigInt", UN "prim__addBigInt"] : usedIn + let used = [sUN "prim__subBigInt", sUN "prim__addBigInt"] : usedIn defsIn <- mkDecls tm (concat used) findUnusedArgs (concat used) maindef <- irMain tm @@ -49,7 +49,7 @@ flags <- getFlags codegen hdrs <- getHdrs codegen impdirs <- allImportDirs - let defs = defsIn ++ [(MN 0 "runMain", maindef)] + let defs = defsIn ++ [(sMN 0 "runMain", maindef)] -- iputStrLn $ showSep "\n" (map show defs) let (nexttag, tagged) = addTags 65536 (liftAll defs) let ctxtIn = addAlist tagged emptyContext @@ -108,7 +108,7 @@ irMain :: TT Name -> Idris LDecl irMain tm = do i <- ir tm - return $ LFun [] (MN 0 "runMain") [] (LForce i) + return $ LFun [] (sMN 0 "runMain") [] (LForce i) mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)] mkDecls t used @@ -137,7 +137,7 @@ = do i <- getIState case lookup n (idris_scprims i) of Just (ar, op) -> - let args = map (\x -> MN x "op") [0..] in + let args = map (\x -> sMN x "op") [0..] in return (n, (LFun [] n (take ar args) (LOp op (map (LV . Glob) (take ar args))))) _ -> do def <- mkLDecl n d @@ -157,7 +157,7 @@ mkLDecl n (Function tm _) = do e <- ir tm return (declArgs [] True n e) -mkLDecl n (CaseOp ci _ _ pats cd) +mkLDecl n (CaseOp ci _ _ _ pats cd) = let (args, sc) = cases_runtime cd in do e <- ir (args, sc) return (declArgs [] (case_inlinable ci) n e) @@ -168,40 +168,41 @@ instance ToIR (TT Name) where ir tm = ir' [] tm where ir' env tm@(App f a) - | (P _ (UN "mkForeignPrim") _, args) <- unApply tm + | (P _ (UN m) _, args) <- unApply tm, + m == txt "mkForeignPrim" = doForeign env args - | (P _ (UN "unsafePerformPrimIO") _, [_, arg]) <- unApply tm + | (P _ (UN u) _, [_, arg]) <- unApply tm, + u == txt "unsafePerformPrimIO" = ir' env arg -- TMP HACK - until we get inlining. - | (P _ (UN "replace") _, [_, _, _, _, _, arg]) <- unApply tm + | (P _ (UN r) _, [_, _, _, _, _, arg]) <- unApply tm, + r == txt "replace" = ir' env arg - | (P _ (UN "lazy") _, [_, arg]) <- unApply tm + | (P _ (UN l) _, [_, arg]) <- unApply tm, + l == txt "lazy" = do arg' <- ir' env arg return $ LLazyExp arg' - | (P _ (UN "assert_smaller") _, [_, _, _, arg]) <- unApply tm + | (P _ (UN a) _, [_, _, arg]) <- unApply tm, + a == txt "assert_smaller" = ir' env arg - | (P _ (UN "par") _, [_, arg]) <- unApply tm + | (P _ (UN a) _, [_, arg]) <- unApply tm, + a == txt "assert_total" + = ir' env arg + | (P _ (UN p) _, [_, arg]) <- unApply tm, + p == txt "par" = do arg' <- ir' env arg return $ LOp LPar [LLazyExp arg'] - | (P _ (UN "prim_fork") _, [arg]) <- unApply tm + | (P _ (UN pf) _, [arg]) <- unApply tm, + pf == txt "prim_fork" = do arg' <- ir' env arg return $ LOp LFork [LLazyExp arg'] --- | (P _ (UN "prim__IO") _, [v]) <- unApply tm --- = do v' <- ir' env v --- return v' --- | (P _ (UN "prim_io_bind") _, [_,_,v,Bind n (Lam _) sc]) <- unApply tm --- = do v' <- ir' env v --- sc' <- ir' (n:env) sc --- return (LLet n (LForce v') sc') --- | (P _ (UN "prim_io_bind") _, [_,_,v,k]) <- unApply tm --- = do v' <- ir' env v --- k' <- ir' env k --- return (LApp False k' [LForce v']) - | (P _ (UN "malloc") _, [_,size,t]) <- unApply tm + | (P _ (UN m) _, [_,size,t]) <- unApply tm, + m == txt "malloc" = do size' <- ir' env size t' <- ir' env t return t' -- TODO $ malloc_ size' t' - | (P _ (UN "trace_malloc") _, [_,t]) <- unApply tm + | (P _ (UN tm) _, [_,t]) <- unApply tm, + tm == txt "trace_malloc" = do t' <- ir' env t return t' -- TODO -- | (P _ (NS (UN "S") ["Nat", "Prelude"]) _, [k]) <- unApply tm @@ -220,13 +221,13 @@ let collapse = case lookupCtxtExact n (idris_optimisation i) of - [oi] -> collapsible oi + Just oi -> collapsible oi _ -> False let unused = case lookupCtxtExact n (idris_callgraph i) of - [CGInfo _ _ _ _ unusedpos] -> - unusedpos + Just (CGInfo _ _ _ _ unusedpos) -> + unusedpos _ -> [] if collapse then return LNothing @@ -272,7 +273,7 @@ (args ++ map (\n -> P Bound n undefined) extra) return $ LLam extra sc' - satArgs n = map (\i -> MN i "sat") [1..n] + satArgs n = map (\i -> sMN i "sat") [1..n] buildApp env e [] = return e buildApp env e xs = do xs' <- mapM (ir' env) xs @@ -300,10 +301,15 @@ fmap (mkIty' ty :) (getFTypes xs) _ -> Nothing -mkIty' (P _ (UN ty) _) = mkIty ty -mkIty' (App (P _ (UN "FIntT") _) (P _ (UN intTy) _)) = mkIntIty intTy -mkIty' (App (App (P _ (UN "FFunction") _) _) (App (P _ (UN "FAny") _) (App (P _ (UN "IO") _) _))) = FFunctionIO -mkIty' (App (App (P _ (UN "FFunction") _) _) _) = FFunction +mkIty' (P _ (UN ty) _) = mkIty (str ty) +mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _)) + | fi == txt "FIntT" = mkIntIty (str intTy) +mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _))) + | ff == txt "FFunction" && fa == txt "FAny" && + io == txt "IO" + = FFunctionIO +mkIty' (App (App (P _ (UN ff) _) _) _) + | ff == txt "FFunction" = FFunction mkIty' _ = FAny -- would be better if these FInt types were evaluated at compile time @@ -337,8 +343,8 @@ mkIntIty "IT32" = FArith (ATInt (ITFixed IT32)) mkIntIty "IT64" = FArith (ATInt (ITFixed IT64)) -zname = NS (UN "Z") ["Nat","Prelude"] -sname = NS (UN "S") ["Nat","Prelude"] +zname = sNS (sUN "Z") ["Nat","Prelude"] +sname = sNS (sUN "S") ["Nat","Prelude"] instance ToIR ([Name], SC) where ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree diff --git a/src/IRTS/Defunctionalise.hs b/src/IRTS/Defunctionalise.hs --- a/src/IRTS/Defunctionalise.hs +++ b/src/IRTS/Defunctionalise.hs @@ -2,7 +2,7 @@ module IRTS.Lang) where import IRTS.Lang -import Core.TT +import Idris.Core.TT import Debug.Trace import Data.Maybe @@ -81,17 +81,17 @@ aa env (LApp tc (LV (Glob n)) args) = do args' <- mapM (aa env) args case lookupCtxtExact 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' + Just (LConstructor _ i ar) -> return $ DApp tc n args' + Just (LFun _ _ as _) -> let arity = length as in + fixApply tc n args' arity + Nothing -> return $ chainAPPLY (DV (Glob n)) args' aa env (LLazyApp n args) = do args' <- mapM (aa env) args case lookupCtxtExact n defs of - [LConstructor _ i ar] -> return $ DApp False n args' - [LFun _ _ as _] -> let arity = length as in - fixLazyApply n args' arity - [] -> return $ chainAPPLY (DV (Glob n)) args' + Just (LConstructor _ i ar) -> return $ DApp False n args' + Just (LFun _ _ as _) -> let arity = length as in + fixLazyApply n args' arity + Nothing -> return $ chainAPPLY (DV (Glob n)) args' aa env (LForce (LLazyApp n args)) = aa env (LApp False (LV (Glob n)) args) aa env (LForce e) = liftM eEVAL (aa env e) aa env (LLet n v sc) = liftM2 (DLet n) (aa env v) (aa (n : env) sc) @@ -143,7 +143,7 @@ = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args) chainAPPLY f [] = f - chainAPPLY f (a : as) = chainAPPLY (DApp False (MN 0 "APPLY") [f, a]) as + chainAPPLY f (a : as) = chainAPPLY (DApp False (sMN 0 "APPLY") [f, a]) as -- if anything in the DExp is projected from, we'll need to evaluate it, -- but we only want to do it once, rather than every time we project. @@ -171,7 +171,7 @@ needsEval x (DProj (DV (Glob x')) _) = x == x' needsEval x _ = False -eEVAL x = DApp False (MN 0 "EVAL") [x] +eEVAL x = DApp False (sMN 0 "EVAL") [x] data EvalApply a = EvalCase (Name -> a) | ApplyCase a @@ -198,26 +198,26 @@ (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0)) (DApp False (mkUnderCon fname (ar - (n + 1))) (map (DV . Glob) (take n (genArgs 0) ++ - [MN 0 "arg"]))))) + [sMN 0 "arg"]))))) : mkApplyCase fname (n + 1) ar mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl) -mkEval xs = (MN 0 "EVAL", DFun (MN 0 "EVAL") [MN 0 "arg"] - (mkBigCase (MN 0 "EVAL") 256 (DV (Glob (MN 0 "arg"))) +mkEval xs = (sMN 0 "EVAL", DFun (sMN 0 "EVAL") [sMN 0 "arg"] + (mkBigCase (sMN 0 "EVAL") 256 (DV (Glob (sMN 0 "arg"))) (mapMaybe evalCase xs ++ - [DDefaultCase (DV (Glob (MN 0 "arg")))]))) + [DDefaultCase (DV (Glob (sMN 0 "arg")))]))) where - evalCase (n, t, EvalCase x) = Just (x (MN 0 "arg")) + evalCase (n, t, EvalCase x) = Just (x (sMN 0 "arg")) evalCase _ = Nothing mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl) -mkApply xs = (MN 0 "APPLY", DFun (MN 0 "APPLY") [MN 0 "fn", MN 0 "arg"] +mkApply xs = (sMN 0 "APPLY", DFun (sMN 0 "APPLY") [sMN 0 "fn", sMN 0 "arg"] (case mapMaybe applyCase xs of [] -> DNothing cases -> - mkBigCase (MN 0 "APPLY") 256 - (DApp False (MN 0 "EVAL") - [DV (Glob (MN 0 "fn"))]) + mkBigCase (sMN 0 "APPLY") 256 + (DApp False (sMN 0 "EVAL") + [DV (Glob (sMN 0 "fn"))]) (cases ++ [DDefaultCase DNothing]))) where @@ -231,11 +231,11 @@ dec' t ((n, ar, _) : xs) acc = dec' (t + 1) xs ((n, DConstructor n t ar) : acc) -genArgs i = MN i "P_c" : genArgs (i + 1) +genArgs i = sMN i "P_c" : genArgs (i + 1) -mkFnCon n = MN 0 ("P_" ++ show n) +mkFnCon n = sMN 0 ("P_" ++ show n) mkUnderCon n 0 = n -mkUnderCon n missing = MN missing ("U_" ++ show n) +mkUnderCon n missing = sMN missing ("U_" ++ show n) instance Show DExp where show e = show' [] e where diff --git a/src/IRTS/DumpBC.hs b/src/IRTS/DumpBC.hs --- a/src/IRTS/DumpBC.hs +++ b/src/IRTS/DumpBC.hs @@ -2,7 +2,7 @@ import IRTS.Lang import IRTS.Simplified -import Core.TT +import Idris.Core.TT import IRTS.Bytecode import Data.List diff --git a/src/IRTS/Inliner.hs b/src/IRTS/Inliner.hs --- a/src/IRTS/Inliner.hs +++ b/src/IRTS/Inliner.hs @@ -1,6 +1,6 @@ module IRTS.Inliner where -import Core.TT +import Idris.Core.TT import IRTS.Defunctionalise diff --git a/src/IRTS/Java/JTypes.hs b/src/IRTS/Java/JTypes.hs --- a/src/IRTS/Java/JTypes.hs +++ b/src/IRTS/Java/JTypes.hs @@ -1,7 +1,7 @@ {-# LANGUAGE PatternGuards #-} module IRTS.Java.JTypes where -import Core.TT +import Idris.Core.TT import IRTS.Lang import Language.Java.Syntax import qualified Language.Java.Syntax as J diff --git a/src/IRTS/Java/Mangling.hs b/src/IRTS/Java/Mangling.hs --- a/src/IRTS/Java/Mangling.hs +++ b/src/IRTS/Java/Mangling.hs @@ -3,7 +3,7 @@ module IRTS.Java.Mangling where -import Core.TT +import Idris.Core.TT import IRTS.Lang import IRTS.Simplified @@ -26,7 +26,7 @@ where prefixCallNamespacesExp :: Ident -> SExp -> SExp prefixCallNamespacesExp (Ident name) (SApp tail (NS n ns) args) = - SApp tail (NS n (name:ns)) args + SApp tail (NS n (txt name:ns)) args prefixCallNamespacesExp name (SLet var e1 e2) = SLet var (prefixCallNamespacesExp name e1) (prefixCallNamespacesExp name e2) prefixCallNamespacesExp name (SUpdate var e) = @@ -63,7 +63,7 @@ . parser ident . (prefix ++) . cleanNonLetter - $ cleanWs False name + $ cleanWs False (str name) where cleanNonLetter (x:xs) | x == '#' = "_Hash" ++ cleanNonLetter xs @@ -88,7 +88,8 @@ | x == ' ' = "_Space" ++ cleanNonLetter xs | x == ',' = "_Comma" ++ cleanNonLetter xs | x == '_' = "__" ++ cleanNonLetter xs - | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs + -- 10 digits is the most possible to represent 2^32 (ie all of unicode) + | not (isAlphaNum x) = "_" ++ (padToWith 10 '0' . show $ ord x) ++ cleanNonLetter xs | otherwise = x:cleanNonLetter xs cleanNonLetter [] = [] cleanWs capitalize (x:xs) @@ -96,7 +97,9 @@ | capitalize = (toUpper x) : (cleanWs False xs) | otherwise = x : (cleanWs False xs) cleanWs _ [] = [] -mangleWithPrefix prefix s@(SN _) = mangleWithPrefix prefix (UN (showCG s)) + padToWith :: Int -> a -> [a] -> [a] + padToWith n p xs = replicate (length xs - n) p ++ xs +mangleWithPrefix prefix s@(SN _) = mangleWithPrefix prefix (sUN (showCG s)) mangle :: (Applicative m, MonadError String m) => Name -> m Ident mangle = mangleWithPrefix "__IDRCG__" diff --git a/src/IRTS/Lang.hs b/src/IRTS/Lang.hs --- a/src/IRTS/Lang.hs +++ b/src/IRTS/Lang.hs @@ -1,10 +1,12 @@ module IRTS.Lang where import Control.Monad.State hiding (lift) -import Core.TT +import Idris.Core.TT import Data.List import Debug.Trace +data Endianness = Native | BE | LE deriving (Show, Eq) + data LVar = Loc Int | Glob Name deriving (Show, Eq) @@ -50,6 +52,15 @@ | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev | LStdIn | LStdOut | LStdErr + -- Buffers + | LAllocate + | LAppendBuffer + -- Note that for Bits8 only Native endianness is actually used + -- and the user-exposed interface for Bits8 doesn't mention + -- endianness + | LAppend IntTy Endianness + | LPeek IntTy Endianness + | LFork | LPar -- evaluate argument anywhere, possibly on another -- core or another machine. 'id' is a valid implementation @@ -102,7 +113,7 @@ lname (NS n x) i = NS (lname n i) x lname (UN n) i = MN i n -lname x i = MN i (show x) +lname x i = sMN i (show x) liftAll :: [(Name, LDecl)] -> [(Name, LDecl)] liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs diff --git a/src/IRTS/Simplified.hs b/src/IRTS/Simplified.hs --- a/src/IRTS/Simplified.hs +++ b/src/IRTS/Simplified.hs @@ -1,7 +1,8 @@ module IRTS.Simplified where import IRTS.Defunctionalise -import Core.TT +import Idris.Core.TT +import Idris.Core.Typecheck import Data.Maybe import Control.Monad.State @@ -47,7 +48,7 @@ simplify tl (DV (Glob x)) = do ctxt <- ldefs case lookupCtxtExact x ctxt of - [DConstructor _ t 0] -> return $ SCon t x [] + Just (DConstructor _ t 0) -> return $ SCon t x [] _ -> return $ SV (Glob x) simplify tl (DApp tc n args) = do args' <- mapM sVar args mkapp (SApp (tl || tc) n) args' @@ -89,12 +90,12 @@ sVar (DV (Glob x)) = do ctxt <- ldefs case lookupCtxtExact x ctxt of - [DConstructor _ t 0] -> sVar (DC t x []) + Just (DConstructor _ t 0) -> sVar (DC t x []) _ -> return (Glob x, Nothing) sVar (DV x) = return (x, Nothing) sVar e = do e' <- simplify False e i <- hvar - return (Glob (MN i "R"), Just e') + return (Glob (sMN i "R"), Just e') mkapp f args = mkapp' f args [] where mkapp' f [] args = return $ f (reverse args) @@ -137,23 +138,23 @@ case lookup n (reverse env) of -- most recent first Just i -> do lvar i; return (SV (Loc i)) Nothing -> case lookupCtxtExact n ctxt of - [DConstructor _ i ar] -> + Just (DConstructor _ i ar) -> if True -- ar == 0 then return (SCon i n []) else fail $ "Codegen error: Constructor " ++ show n ++ " has arity " ++ show ar - [_] -> return (SV (Glob n)) - [] -> fail $ "Codegen error: No such variable " ++ show n + Just _ -> return (SV (Glob n)) + Nothing -> fail $ "Codegen error: No such variable " ++ show n sc env (SApp tc f args) = do args' <- mapM (scVar env) args case lookupCtxtExact f ctxt of - [DConstructor n tag ar] -> + Just (DConstructor n tag ar) -> if True -- (ar == length args) then return $ SCon tag n args' else fail $ "Codegen error: Constructor " ++ show f ++ " has arity " ++ show ar - [_] -> return $ SApp tc f args' - [] -> fail $ "Codegen error: No such variable " ++ show f + Just _ -> return $ SApp tc f args' + Nothing -> fail $ "Codegen error: No such variable " ++ show f sc env (SForeign l ty f args) = do args' <- mapM (\ (t, a) -> do a' <- scVar env a return (t, a')) args @@ -161,7 +162,7 @@ sc env (SCon tag f args) = do args' <- mapM (scVar env) args case lookupCtxtExact f ctxt of - [DConstructor n tag ar] -> + Just (DConstructor n tag ar) -> if True -- (ar == length args) then return $ SCon tag n args' else fail $ "Codegen error: Constructor " ++ show f ++ @@ -198,17 +199,17 @@ case lookup n (reverse env) of -- most recent first Just i -> do lvar i; return (Loc i) Nothing -> case lookupCtxtExact n ctxt of - [DConstructor _ i ar] -> + Just (DConstructor _ i ar) -> fail $ "Codegen error : can't pass constructor here" - [_] -> return (Glob n) - [] -> fail $ "Codegen error: No such variable " ++ show n ++ - " in " ++ show tm ++ " " ++ show envTop + Just _ -> return (Glob n) + Nothing -> fail $ "Codegen error: No such variable " ++ show n ++ + " in " ++ show tm ++ " " ++ show envTop scVar _ x = return x scalt env (SConCase _ i n args e) = do let env' = env ++ zip args [length env..] tag <- case lookupCtxtExact n ctxt of - [DConstructor _ i ar] -> + Just (DConstructor _ i ar) -> if True -- (length args == ar) then return i else fail $ "Codegen error: Constructor " ++ show n ++ diff --git a/src/IRTS/System.hs b/src/IRTS/System.hs new file mode 100644 --- /dev/null +++ b/src/IRTS/System.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} +module IRTS.System(getTargetDir,getCC,getLibFlags,getIdrisLibDir, + getIncFlags,getMvn,getExecutablePom) where + +import Util.System + +import Control.Applicative ((<$>)) +import Data.Maybe (fromMaybe) +import System.FilePath ((), addTrailingPathSeparator) +import System.Environment + +import Paths_idris + +getCC :: IO String +getCC = fromMaybe "gcc" <$> environment "IDRIS_CC" + +mvnCommand :: String +#ifdef mingw32_HOST_OS +mvnCommand = "mvn.bat" +#else +mvnCommand = "mvn" +#endif + +getMvn :: IO String +getMvn = fromMaybe mvnCommand <$> environment "IDRIS_MVN" + +environment :: String -> IO (Maybe String) +environment x = catchIO (do e <- getEnv x + return (Just e)) + (\_ -> return Nothing) + +getTargetDir :: IO String +getTargetDir = environment "TARGET" >>= maybe getDataDir return + +#if defined(FREEBSD) || defined(DRAGONFLY) +extraLib = " -L/usr/local/lib" +#else +extraLib = "" +#endif + +#ifdef IDRIS_GMP +gmpLib = " -lgmp" +#else +gmpLib = "" +#endif + +getLibFlags = do dir <- getDataDir + return $ "-L" ++ (dir "rts") ++ + " -lidris_rts" ++ extraLib ++ gmpLib ++ " -lpthread" + +getIdrisLibDir = do dir <- getDataDir + return $ addTrailingPathSeparator dir + +#if defined(FREEBSD) || defined(DRAGONFLY) +extraInclude = " -I/usr/local/include" +#else +extraInclude = "" +#endif +getIncFlags = do dir <- getDataDir + return $ "-I" ++ dir "rts" ++ extraInclude + +getExecutablePom = do dir <- getDataDir + return $ dir "java" "executable_pom.xml" diff --git a/src/Idris/AbsSyntax.hs b/src/Idris/AbsSyntax.hs --- a/src/Idris/AbsSyntax.hs +++ b/src/Idris/AbsSyntax.hs @@ -3,10 +3,10 @@ module Idris.AbsSyntax(module Idris.AbsSyntax, module Idris.AbsSyntaxTree) where -import Core.TT -import Core.Evaluate -import Core.Elaborate hiding (Tactic(..)) -import Core.Typecheck +import Idris.Core.TT +import Idris.Core.Evaluate +import Idris.Core.Elaborate hiding (Tactic(..)) +import Idris.Core.Typecheck import Idris.AbsSyntaxTree import Idris.Colours import Idris.IdeSlave @@ -19,11 +19,15 @@ import System.IO import Control.Monad.State +import Control.Monad.Error(throwError) import Data.List import Data.Char +import qualified Data.Text as T import Data.Either +import qualified Data.Map as M import Data.Maybe +import qualified Data.Set as S import Data.Word (Word) import Debug.Trace @@ -32,6 +36,7 @@ import System.IO.Error(isUserError, ioeGetErrorString, tryIOError) import Util.Pretty +import Util.ScreenSize import Util.System getContext :: Idris Context @@ -93,6 +98,10 @@ addTrans t = do i <- getIState putIState $ i { idris_transforms = t : idris_transforms i } +addErrRev :: (Term, Term) -> Idris () +addErrRev t = do i <- getIState + putIState $ i { idris_errRev = t : idris_errRev i } + totcheck :: (FC, Name) -> Idris () totcheck n = do i <- getIState; putIState $ i { idris_totcheck = idris_totcheck i ++ [n] } @@ -135,10 +144,10 @@ where findCoercions t [] = [] findCoercions t (n : ns) = let ps = case lookupTy n (tt_ctxt i) of - [ty] -> case unApply (getRetTy ty) of + [ty'] -> case unApply (getRetTy ty') of (t', _) -> if t == t' then [n] else [] - _ -> [] in + _ -> [] in ps ++ findCoercions t ns addToCG :: Name -> CGInfo -> Idris () @@ -146,6 +155,24 @@ = do i <- getIState putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) } +-- | Adds error handlers for a particular function and argument. If names are is ambiguous, all matching handlers are updated. +addFunctionErrorHandlers :: Name -> Name -> [Name] -> Idris () +addFunctionErrorHandlers f arg hs = + do i <- getIState + let oldHandlers = idris_function_errorhandlers i + let newHandlers = flip (addDef f) oldHandlers $ + case lookupCtxtExact f oldHandlers of + Nothing -> M.singleton arg (S.fromList hs) + Just (oldHandlers) -> M.insertWith S.union arg (S.fromList hs) oldHandlers + -- will always be one of those two, thus no extra case + putIState $ i { idris_function_errorhandlers = newHandlers } + +getFunctionErrorHandlers :: Name -> Name -> Idris [Name] +getFunctionErrorHandlers f arg = do i <- getIState + return . maybe [] S.toList $ + undefined --lookup arg =<< lookupCtxtExact f (idris_function_errorhandlers i) + + -- Trace all the names in a call graph starting at the given name getAllNames :: Name -> Idris [Name] getAllNames n = allNames [] n @@ -154,8 +181,8 @@ allNames ns n | n `elem` ns = return [] allNames ns n = do i <- getIState case lookupCtxtExact n (idris_callgraph i) of - [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns')) - return (nub (n : concat more)) + Just ns' -> do more <- mapM (allNames (n:ns)) (map fst (calls ns')) + return (nub (n : concat more)) _ -> return [n] addCoercion :: Name -> Idris () @@ -180,7 +207,7 @@ putIState $ i { idris_namehints = addDef ty' ns' (idris_namehints i) } getNameHints :: IState -> Name -> [Name] -getNameHints i (UN "->") = [UN "f",UN "g"] +getNameHints i (UN arr) | arr == txt "->" = [sUN "f",sUN "g"] getNameHints i n = case lookupCtxt n (idris_namehints i) of [ns] -> ns @@ -197,10 +224,10 @@ addInstance int n i = do ist <- getIState 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) + [CI a b c d e ins] -> + do let cs = addDef n (CI a b c d e (addI i ins)) (idris_classes ist) putIState $ ist { idris_classes = cs } - _ -> do let cs = addDef n (CI (MN 0 "none") [] [] [] [i]) (idris_classes ist) + _ -> do let cs = addDef n (CI (sMN 0 "none") [] [] [] [] [i]) (idris_classes ist) putIState $ ist { idris_classes = cs } where addI i ins | int = i : ins | chaser n = ins ++ [i] @@ -209,7 +236,8 @@ insI i (n : ns) | chaser n = i : n : ns | otherwise = n : insI i ns - chaser (UN ('@':'@':_)) = True + chaser (UN nm) + | ('@':'@':_) <- str nm = True chaser (NS n _) = chaser n chaser _ = False @@ -234,6 +262,24 @@ clearIBC :: Idris () clearIBC = do i <- getIState; putIState $ i { ibc_write = [] } +resetNameIdx :: Idris () +resetNameIdx = do i <- getIState + put (i { idris_nameIdx = (0, emptyContext) }) + +-- Used to preserve sharing of names +addNameIdx :: Name -> Idris (Int, Name) +addNameIdx n = do i <- getIState + let (i', x) = addNameIdx' i n + return x + +addNameIdx' :: IState -> Name -> (IState, (Int, Name)) +addNameIdx' i n + = let idxs = snd (idris_nameIdx i) in + case lookupCtxt n idxs of + [x] -> (i, x) + _ -> let i' = fst (idris_nameIdx i) + 1 in + (i { idris_nameIdx = (i', addDef n (i', n) idxs) }, (i', n)) + getHdrs :: Codegen -> Idris [String] getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i) @@ -284,12 +330,33 @@ Nothing -> return Placeholder -- TODO: What if it's not there? +-- Pattern definitions are only used for coverage checking, so erase them +-- when we're done +clearOrigPats :: Idris () +clearOrigPats = do i <- get + let ps = idris_patdefs i + let ps' = mapCtxt (\ (_,miss) -> ([], miss)) ps + put (i { idris_patdefs = ps' }) + +-- Erase types from Ps in the context (basically ending up with what's in +-- the .ibc, which is all we need after all the analysis is done) +clearPTypes :: Idris () +clearPTypes = do i <- get + let ctxt = tt_ctxt i + put (i { tt_ctxt = mapDefCtxt pErase ctxt }) + where pErase (CaseOp c t tys orig tot cds) + = CaseOp c t tys orig [] (pErase' cds) + pErase x = x + pErase' (CaseDefs _ (cs, c) _ rs) + = let c' = (cs, fmap pEraseType c) in + CaseDefs c' c' c' rs + checkUndefined :: FC -> Name -> Idris () checkUndefined fc n = do i <- getContext case lookupTy n i of - (_:_) -> fail $ show fc ++ ":" ++ - show n ++ " already defined" + (_:_) -> throwError . Msg $ show fc ++ ":" ++ + show n ++ " already defined" _ -> return () isUndefined :: FC -> Name -> Idris Bool @@ -337,6 +404,36 @@ filter (\(n', _) -> n/=n') (idris_metavars i) } +getUndefined :: Idris [Name] +getUndefined = do i <- getIState + return (map fst (idris_metavars i) \\ primDefs) + +getWidth :: Idris ConsoleWidth +getWidth = fmap idris_consolewidth getIState + +setWidth :: ConsoleWidth -> Idris () +setWidth w = do ist <- getIState + put ist { idris_consolewidth = w } + +renderWidth :: Idris Int +renderWidth = do iw <- getWidth + case iw of + InfinitelyWide -> return 100000000 + ColsWide n -> return (max n 1) + AutomaticWidth -> runIO getScreenWidth + + +iRender :: Doc a -> Idris (SimpleDoc a) +iRender d = do w <- getWidth + case w of + InfinitelyWide -> return $ renderPretty 1.0 1000000000 d + ColsWide n -> return $ + if n < 1 + then renderPretty 1.0 1000000000 d + else renderPretty 0.8 n d + AutomaticWidth -> do width <- runIO getScreenWidth + return $ renderPretty 0.8 width d + ihPrintResult :: Handle -> String -> Idris () ihPrintResult h s = do i <- getIState case idris_outputmode i of @@ -347,6 +444,63 @@ let good = SexpList [SymbolAtom "ok", toSExp s] in runIO $ hPutStrLn h $ convSExp "return" good n +-- | Write a pretty-printed term to the console with semantic coloring +consoleDisplayAnnotated :: Handle -> Doc OutputAnnotation -> Idris () +consoleDisplayAnnotated h output = do ist <- getIState + rendered <- iRender $ output + runIO . hPutStrLn h . + displayDecorated (consoleDecorate ist) $ + rendered + + +-- | Write pretty-printed output to IDESlave with semantic annotations +ideSlaveReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris () +ideSlaveReturnAnnotated n h out = do ist <- getIState + (str, spans) <- fmap displaySpans . + iRender . + fmap (fancifyAnnots ist) $ + out + let good = [SymbolAtom "ok", toSExp str, toSExp spans] + runIO . hPutStrLn h $ convSExp "return" good n + +ihPrintTermWithType :: Handle -> Doc OutputAnnotation -> Doc OutputAnnotation -> Idris () +ihPrintTermWithType h tm ty = do ist <- getIState + let output = tm <+> colon <+> ty + case idris_outputmode ist of + RawOutput -> consoleDisplayAnnotated h output + IdeSlave n -> ideSlaveReturnAnnotated n h output + +-- | Pretty-print a collection of overloadings to REPL or IDESlave - corresponds to :t name +ihPrintFunTypes :: Handle -> Name -> [(Name, PTerm)] -> Idris () +ihPrintFunTypes h n [] = ihPrintError h $ "No such variable " ++ show n +ihPrintFunTypes h n overloads = do imp <- impShow + ist <- getIState + let output = vsep (map (uncurry (ppOverload imp)) overloads) + case idris_outputmode ist of + RawOutput -> consoleDisplayAnnotated h output + IdeSlave n -> ideSlaveReturnAnnotated n h output + where fullName n = annotate (AnnName n Nothing Nothing) $ text (show n) + ppOverload imp n tm = fullName n <+> colon <+> align (prettyImp imp tm) + +ihRenderResult :: Handle -> Doc OutputAnnotation -> Idris () +ihRenderResult h d = do ist <- getIState + case idris_outputmode ist of + RawOutput -> consoleDisplayAnnotated h d + IdeSlave n -> ideSlaveReturnAnnotated n h d + +fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation +fancifyAnnots ist annot@(AnnName n _ _) = + do let ctxt = tt_ctxt ist + case () of + _ | isDConName n ctxt -> AnnName n (Just DataOutput) Nothing + _ | isFnName n ctxt -> AnnName n (Just FunOutput) Nothing + _ | isTConName n ctxt -> AnnName n (Just TypeOutput) Nothing + _ | otherwise -> annot +fancifyAnnots _ annot = annot + +type1Doc :: Doc OutputAnnotation +type1Doc = (annotate AnnConstType $ text "Type 1") + ihPrintError :: Handle -> String -> Idris () ihPrintError h s = do i <- getIState case idris_outputmode i of @@ -375,11 +529,12 @@ _ -> return () -- this needs some typing magic and more structured output towards emacs -iputGoal :: String -> Idris () -iputGoal s = do i <- getIState +iputGoal :: SimpleDoc OutputAnnotation -> Idris () +iputGoal g = do i <- getIState case idris_outputmode i of - RawOutput -> runIO $ putStrLn s - IdeSlave n -> runIO . putStrLn $ convSExp "write-goal" s n + RawOutput -> runIO $ putStrLn (displayDecorated (consoleDecorate i) g) + IdeSlave n -> runIO . putStrLn $ + convSExp "write-goal" (displayS (fmap (fancifyAnnots i) g) "") n isetPrompt :: String -> Idris () isetPrompt p = do i <- getIState @@ -390,7 +545,7 @@ ihWarn h fc err = do i <- getIState case idris_outputmode i of RawOutput -> runIO $ hPutStrLn h (show fc ++ ":" ++ err) - IdeSlave n -> runIO $ hPutStrLn h $ convSExp "warning" (fc_fname fc, fc_line fc, err) n + IdeSlave n -> runIO $ hPutStrLn h $ convSExp "warning" (fc_fname fc, fc_line fc, fc_column fc, err) n setLogLevel :: Int -> Idris () setLogLevel l = do i <- getIState @@ -445,10 +600,20 @@ let opt' = opts { opt_repl = t } putIState $ i { idris_options = opt' } +showOrigErr :: Idris Bool +showOrigErr = do i <- getIState + return (opt_origerr (idris_options i)) + +setShowOrigErr :: Bool -> Idris () +setShowOrigErr b = do i <- getIState + let opts = idris_options i + let opt' = opts { opt_origerr = b } + putIState $ i { idris_options = opt' } + setNoBanner :: Bool -> Idris () setNoBanner n = do i <- getIState let opts = idris_options i - let opt' = opts {opt_nobanner = n} + let opt' = opts { opt_nobanner = n } putIState $ i { idris_options = opt' } getNoBanner :: Idris Bool @@ -642,90 +807,6 @@ putIState $ i { idris_options = opt' } --- For inferring types of things - -bi = fileFC "builtin" - -inferTy = MN 0 "__Infer" -inferCon = MN 0 "__infer" -inferDecl = PDatadecl inferTy - PType - [("", inferCon, PPi impl (MN 0 "A") PType ( - PPi expl (MN 0 "a") (PRef bi (MN 0 "A")) - (PRef bi inferTy)), bi)] -inferOpts = [] - -infTerm t = PApp bi (PRef bi inferCon) [pimp (MN 0 "A") Placeholder True, pexp t] -infP = P (TCon 6 0) inferTy (TType (UVal 0)) - -getInferTerm, getInferType :: Term -> Term -getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc -getInferTerm (App (App _ _) tm) = tm -getInferTerm tm = tm -- error ("getInferTerm " ++ show tm) - -getInferType (Bind n b sc) = Bind n b $ getInferType sc -getInferType (App (App _ ty) _) = ty - --- Handy primitives: Unit, False, Pair, MkPair, =, mkForeign, Elim type class - -primNames = [unitTy, unitCon, - falseTy, pairTy, pairCon, - eqTy, eqCon, inferTy, inferCon] - -unitTy = MN 0 "__Unit" -unitCon = MN 0 "__II" -unitDecl = PDatadecl unitTy PType - [("", unitCon, PRef bi unitTy, bi)] -unitOpts = [DefaultEliminator] - -falseTy = MN 0 "__False" -falseDecl = PDatadecl falseTy PType [] -falseOpts = [] - -pairTy = MN 0 "__Pair" -pairCon = MN 0 "__MkPair" -pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType) - [("", pairCon, PPi impl (n "A") PType ( - PPi impl (n "B") PType ( - PPi expl (n "a") (PRef bi (n "A")) ( - PPi expl (n "b") (PRef bi (n "B")) - (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")), - pexp (PRef bi (n "B"))])))), bi)] - where n a = MN 0 a -pairOpts = [] - -eqTy = UN "=" -eqCon = UN "refl" -eqDecl = PDatadecl eqTy (piBind [(n "a", PType), (n "b", PType), - (n "x", PRef bi (n "a")), (n "y", PRef bi (n "b"))] - PType) - [("", eqCon, PPi impl (n "a") PType ( - PPi impl (n "x") (PRef bi (n "a")) - (PApp bi (PRef bi eqTy) [pimp (n "a") Placeholder False, - pimp (n "b") Placeholder False, - pexp (PRef bi (n "x")), - pexp (PRef bi (n "x"))])), bi)] - where n a = MN 0 a -eqOpts = [] - -elimName = UN "__Elim" -elimMethElimTy = UN "__elimTy" -elimMethElim = UN "elim" -elimDecl = PClass "Type class for eliminators" defaultSyntax bi [] elimName [(UN "scrutineeType", PType)] - [PTy "" defaultSyntax bi [TotalFn] elimMethElimTy PType, - PTy "" defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)] - --- Defined in builtins.idr -sigmaTy = UN "Exists" -existsCon = UN "Ex_intro" - -piBind :: [(Name, PTerm)] -> PTerm -> PTerm -piBind = piBindp expl - -piBindp :: Plicity -> [(Name, PTerm)] -> PTerm -> PTerm -piBindp p [] t = t -piBindp p ((n, ty):ns) t = PPi p n ty (piBindp p ns t) - -- Dealing with parameters expandParams :: (Name -> Name) -> [(Name, PTerm)] -> @@ -767,7 +848,7 @@ en (PEq f l r) = PEq f (en l) (en r) en (PRewrite f l r g) = PRewrite f (en l) (en r) (fmap en g) en (PTyped l r) = PTyped (en l) (en r) - en (PPair f l r) = PPair f (en l) (en r) + en (PPair f p l r) = PPair f p (en l) (en r) en (PDPair f l t r) = PDPair f (en l) (en t) (en r) en (PAlternative a as) = PAlternative a (map en as) en (PHidden t) = PHidden (en t) @@ -855,13 +936,13 @@ updateps yn nm [] = [] updateps yn nm (((a, t), i):as) | (a `elem` nm) == yn = (a, t) : updateps yn nm as - | otherwise = (MN i (show n ++ "_u"), t) : updateps yn nm as + | otherwise = (sMN i (show n ++ "_u"), t) : updateps yn nm as removeBound lhs ns = ns \\ nub (bnames lhs) bnames (PRef _ n) = [n] bnames (PApp _ _ args) = concatMap bnames (map getTm args) - bnames (PPair _ l r) = bnames l ++ bnames r + bnames (PPair _ _ l r) = bnames l ++ bnames r bnames (PDPair _ l Placeholder r) = bnames l ++ bnames r bnames _ = [] @@ -875,8 +956,8 @@ then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty)) (map econ cons) else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons) - econ (doc, n, t, fc) - = (doc, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc) + econ (doc, n, t, fc, fs) + = (doc, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc, fs) expandParamsD rhs ist dec ps ns (PParams f params pds) = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params) (map (expandParamsD True ist dec ps ns) pds) @@ -917,7 +998,7 @@ ((P Ref _ _):_) -> 1 [] -> 0 -- must be locally bound, if it's not an error... pri (PPi _ _ x y) = max 5 (max (pri x) (pri y)) - pri (PTrue _) = 0 + pri (PTrue _ _) = 0 pri (PFalse _) = 0 pri (PRefl _ _) = 1 pri (PEq _ l r) = max 1 (max (pri l) (pri r)) @@ -926,7 +1007,7 @@ pri (PAppBind _ 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 - pri (PPair _ l r) = max 1 (max (pri l) (pri r)) + pri (PPair _ _ l r) = max 1 (max (pri l) (pri r)) pri (PDPair _ l t r) = max 1 (max (pri l) (max (pri t) (pri r))) pri (PAlternative a as) = maximum (map pri as) pri (PConstant _) = 0 @@ -994,12 +1075,12 @@ -- 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") + = PPi (Constraint [] Dynamic "") (sMN 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) + (map (\n -> PExp 0 [] (PRef fc n) "") args) getConstraints (PPi (Constraint _ _ _) _ c sc) = getcapp c ++ getConstraints sc @@ -1064,7 +1145,7 @@ imps top env (PPi (Imp l _ doc _) n ty sc) = do let isn = nub (namesIn uvars ist ty) `dropAll` [n] (decls , ns) <- get - put (PImp (getPriority ist ty) True l n ty doc : decls, + put (PImp (getPriority ist ty) True l n Placeholder doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc imps top env (PPi (Exp l _ doc _) n ty sc) @@ -1072,7 +1153,7 @@ (PRef _ x) -> namesIn uvars ist sc `dropAll` [n] _ -> []) (decls, ns) <- get -- ignore decls in HO types - put (PExp (getPriority ist ty) l ty doc : decls, + put (PExp (getPriority ist ty) l Placeholder doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc imps top env (PPi (Constraint l _ doc) n ty sc) @@ -1080,7 +1161,7 @@ (PRef _ x) -> namesIn uvars ist sc `dropAll` [n] _ -> []) (decls, ns) <- get -- ignore decls in HO types - put (PConstraint 10 l ty doc : decls, + put (PConstraint 10 l Placeholder doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc imps top env (PPi (TacImp l _ scr doc) n ty sc) @@ -1088,7 +1169,7 @@ (PRef _ x) -> namesIn uvars ist sc `dropAll` [n] _ -> []) (decls, ns) <- get -- ignore decls in HO types - put (PTacImplicit 10 l n scr ty doc : decls, + put (PTacImplicit 10 l n scr Placeholder doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc imps top env (PEq _ l r) @@ -1101,7 +1182,7 @@ 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) + imps top env (PPair _ _ 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))))) @@ -1129,8 +1210,8 @@ pibind using [] sc = sc pibind using (n:ns) sc = case lookup n using of - Just ty -> PPi (Imp False Dynamic "" False) n ty (pibind using ns sc) - Nothing -> PPi (Imp False Dynamic "" False) n Placeholder + Just ty -> PPi (Imp [] Dynamic "" False) n ty (pibind using ns sc) + Nothing -> PPi (Imp [] Dynamic "" False) n Placeholder (pibind using ns sc) -- Add implicit arguments in function calls @@ -1150,71 +1231,84 @@ -- and *not* inside a PHidden addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm -addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm +addImpl' inpat env infns ist ptm + = mkUniqueNames env (ai (zip env (repeat Nothing)) [] ptm) where - ai env (PRef fc f) + ai env ds (PRef fc f) | f `elem` infns = PInferRef fc f - | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat ist fc f [] - ai env (PHidden (PRef fc f)) - | not (f `elem` map fst env) = handleErr $ aiFn inpat False ist fc f [] - 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 g) = let l' = ai env l - r' = ai env r - g' = fmap (ai env) g in - PRewrite fc l' r' g' - ai env (PTyped l r) = let l' = ai env l - r' = ai env r in - PTyped l' r' - ai env (PPair fc l r) = let l' = ai env l - r' = ai env r in - PPair fc l' r' - ai env (PDPair fc l t r) = let l' = ai env l - t' = ai env t - r' = ai env r in - PDPair fc l' t' r' - ai env (PAlternative a as) = let as' = map (ai env) as in - PAlternative a as' - ai env (PApp fc (PInferRef _ f) as) - = let as' = map (fmap (ai env)) as in + | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat ist fc f ds [] + ai env ds (PHidden (PRef fc f)) + | not (f `elem` map fst env) = handleErr $ aiFn inpat False ist fc f ds [] + ai env ds (PEq fc l r) + = let l' = ai env ds l + r' = ai env ds r in + PEq fc l' r' + ai env ds (PRewrite fc l r g) + = let l' = ai env ds l + r' = ai env ds r + g' = fmap (ai env ds) g in + PRewrite fc l' r' g' + ai env ds (PTyped l r) + = let l' = ai env ds l + r' = ai env ds r in + PTyped l' r' + ai env ds (PPair fc p l r) + = let l' = ai env ds l + r' = ai env ds r in + PPair fc p l' r' + ai env ds (PDPair fc l t r) + = let l' = ai env ds l + t' = ai env ds t + r' = ai env ds r in + PDPair fc l' t' r' + ai env ds (PAlternative a as) + = let as' = map (ai env ds) as in + PAlternative a as' + ai env _ (PDisamb ds' as) = ai env ds' as + ai env ds (PApp fc (PInferRef _ f) as) + = let as' = map (fmap (ai env ds)) as in PApp fc (PInferRef fc f) as' - ai env (PApp fc ftm@(PRef _ f) as) - | f `elem` infns = ai env (PApp fc (PInferRef fc f) as) + ai env ds (PApp fc ftm@(PRef _ f) as) + | f `elem` infns = ai env ds (PApp fc (PInferRef fc f) as) | not (f `elem` map fst env) - = let as' = map (fmap (ai env)) as in - handleErr $ aiFn inpat False ist fc f as' - | Just (Just ty) <- lookup f env - = let as' = map (fmap (ai env)) as - arity = getPArity ty in - mkPApp fc arity ftm as' - ai env (PApp fc f as) = let f' = ai env f - as' = map (fmap (ai env)) as in - mkPApp fc 1 f' as' - ai env (PCase fc c os) = let c' = ai env c - os' = map (pmap (ai env)) os in - PCase fc c' os' - ai env (PLam n ty sc) = let ty' = ai env ty - sc' = ai ((n, Just ty):env) sc in - PLam n ty' sc' - ai env (PLet n ty val sc) - = let ty' = ai env ty - val' = ai env val - sc' = ai ((n, Just ty):env) sc in - PLet n ty' val' sc' - ai env (PPi p n ty sc) = let ty' = ai env ty - sc' = ai ((n, Just ty):env) sc in - PPi p n ty' sc' - ai env (PGoal fc r n sc) = let r' = ai env r - sc' = ai ((n, Nothing):env) sc in - PGoal fc r' n sc' - ai env (PHidden tm) = PHidden (ai env tm) - ai env (PProof ts) = PProof (map (fmap (ai env)) ts) - ai env (PTactics ts) = PTactics (map (fmap (ai env)) ts) - ai env (PRefl fc tm) = PRefl fc (ai env tm) - ai env (PUnifyLog tm) = PUnifyLog (ai env tm) - ai env (PNoImplicits tm) = PNoImplicits (ai env tm) - ai env tm = tm + = let as' = map (fmap (ai env ds)) as in + handleErr $ aiFn inpat False ist fc f ds as' + | Just (Just ty) <- lookup f env = + let as' = map (fmap (ai env ds)) as + arity = getPArity ty in + mkPApp fc arity ftm as' + ai env ds (PApp fc f as) + = let f' = ai env ds f + as' = map (fmap (ai env ds)) as in + mkPApp fc 1 f' as' + ai env ds (PCase fc c os) + = let c' = ai env ds c + os' = map (pmap (ai env ds)) os in + PCase fc c' os' + ai env ds (PLam n ty sc) + = let ty' = ai env ds ty + sc' = ai ((n, Just ty):env) ds sc in + PLam n ty' sc' + ai env ds (PLet n ty val sc) + = let ty' = ai env ds ty + val' = ai env ds val + sc' = ai ((n, Just ty):env) ds sc in + PLet n ty' val' sc' + ai env ds (PPi p n ty sc) + = let ty' = ai env ds ty + sc' = ai ((n, Just ty):env) ds sc in + PPi p n ty' sc' + ai env ds (PGoal fc r n sc) + = let r' = ai env ds r + sc' = ai ((n, Nothing):env) ds sc in + PGoal fc r' n sc' + ai env ds (PHidden tm) = PHidden (ai env ds tm) + ai env ds (PProof ts) = PProof (map (fmap (ai env ds)) ts) + ai env ds (PTactics ts) = PTactics (map (fmap (ai env ds)) ts) + ai env ds (PRefl fc tm) = PRefl fc (ai env ds tm) + ai env ds (PUnifyLog tm) = PUnifyLog (ai env ds tm) + ai env ds (PNoImplicits tm) = PNoImplicits (ai env ds tm) + ai env ds tm = tm handleErr (Left err) = PElabError err handleErr (Right x) = x @@ -1222,8 +1316,8 @@ -- if in a pattern, and there are no arguments, and there's no possible -- names with zero explicit arguments, don't add implicits. -aiFn :: Bool -> Bool -> IState -> FC -> Name -> [PArg] -> Either Err PTerm -aiFn inpat True ist fc f [] +aiFn :: Bool -> Bool -> IState -> FC -> Name -> [[T.Text]] -> [PArg] -> Either Err PTerm +aiFn inpat True ist fc f ds [] = case lookupDef f (tt_ctxt ist) of [] -> Right $ PPatvar fc f alts -> let ialts = lookupCtxtName f (idris_implicits ist) in @@ -1231,7 +1325,7 @@ if (not (vname f) || tcname f || any (conCaf (tt_ctxt ist)) ialts) -- any constructor alts || any allImp ialts)) - then aiFn inpat False ist fc f [] -- use it as a constructor + then aiFn inpat False ist fc f ds [] -- use it as a constructor else Right $ PPatvar fc f where imp (PExp _ _ _ _) = False imp _ = True @@ -1245,22 +1339,32 @@ vname (UN n) = True -- non qualified vname _ = False -aiFn inpat expat ist fc f as +aiFn inpat expat ist fc f ds as | f `elem` primNames = Right $ PApp fc (PRef fc f) as -aiFn inpat expat ist fc f as +aiFn inpat expat ist fc f ds as -- This is where namespaces get resolved by adding PAlternative = do let ns = lookupCtxtName f (idris_implicits ist) - let ns' = filter (\(n, _) -> notHidden n) ns + let nh = filter (\(n, _) -> notHidden n) ns + let ns' = case trimAlts ds nh of + [] -> nh + x -> x case ns' of [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as) [] -> if f `elem` (map fst (idris_metavars ist)) then Right $ PApp fc (PRef fc f) as else Right $ mkPApp fc (length as) (PRef fc f) as alts -> Right $ - PAlternative True $ - map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f') - (insertImpl ns as)) alts + PAlternative True $ + map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f') + (insertImpl ns as)) alts where + trimAlts [] alts = alts + trimAlts ns alts + = filter (\(x, _) -> any (\d -> d `isPrefixOf` nspace x) ns) alts + + nspace (NS _ s) = s + nspace _ = [] + notHidden n = case getAccessibility n of Hidden -> False _ -> True @@ -1282,7 +1386,8 @@ case find n given [] of Just (tm, given') -> PImp p False l n tm "" : insertImpl ps given' Nothing -> PImp p True l n Placeholder "" : insertImpl ps given - insertImpl (PTacImplicit p l n sc ty d : ps) given = + insertImpl (PTacImplicit p l n sc' ty d : ps) given = + let sc = addImpl ist sc' in case find n given [] of Just (tm, given') -> PTacImplicit p l n sc tm "" : insertImpl ps given' Nothing -> if inpat @@ -1350,7 +1455,7 @@ = let alts' = filter (/= Placeholder) (map su alts) in if null alts' then Placeholder else PAlternative b alts' - su (PPair fc l r) = PPair fc (su l) (su r) + su (PPair fc p l r) = PPair fc p (su l) (su r) su (PDPair fc l t r) = PDPair fc (su l) (su t) (su r) su t = t stripUnmatchable i tm = tm @@ -1368,7 +1473,7 @@ -- FIXME: It's possible that this really has to happen after elaboration findStatics :: IState -> PTerm -> (PTerm, [Bool]) -findStatics ist tm = trace (showImp Nothing True False tm) $ +findStatics ist tm = trace (show tm) $ let (ns, ss) = fs tm in runState (pos ns ss tm) [] where fs (PPi p n t sc) @@ -1418,12 +1523,14 @@ fullApp x = x match' x y = match (fullApp x) (fullApp y) - match (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x]) x' - | PConstant (I _) <- getTm x = match (getTm x) x' - match x' (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x]) - | PConstant (I _) <- getTm x = match (getTm x) x' - match (PApp _ (PRef _ (UN "lazy")) [_,x]) x' = match (getTm x) x' - match x (PApp _ (PRef _ (UN "lazy")) [_,x']) = match x (getTm x') + match (PApp _ (PRef _ (NS (UN fi) [b])) [_,_,x]) x' + | fi == txt "fromInteger" && b == txt "builtins", + PConstant (I _) <- getTm x = match (getTm x) x' + match x' (PApp _ (PRef _ (NS (UN fi) [b])) [_,_,x]) + | fi == txt "fromInteger" && b == txt "builtins", + PConstant (I _) <- getTm x = match (getTm x) x' + match (PApp _ (PRef _ (UN l)) [_,x]) x' | l == txt "lazy" = match (getTm x) x' + match x (PApp _ (PRef _ (UN l)) [_,x']) | l == txt "lazy" = match x (getTm x') match (PApp _ f args) (PApp _ f' args') | length args == length args' = do mf <- match' f f' @@ -1457,9 +1564,9 @@ return (ml ++ mr) match (PTyped l r) x = match l x match x (PTyped l r) = match x l - match (PPair _ l r) (PPair _ l' r') = do ml <- match' l l' - mr <- match' r r' - return (ml ++ mr) + match (PPair _ _ l r) (PPair _ _ l' r') = do ml <- match' l l' + mr <- match' r r' + return (ml ++ mr) match (PDPair _ l t r) (PDPair _ l' t' r') = do ml <- match' l l' mt <- match' t t' mr <- match' r r' @@ -1480,7 +1587,7 @@ match (PTactics _) _ = return [] match (PRefl _ _) (PRefl _ _) = return [] match (PResolveTC _) (PResolveTC _) = return [] - match (PTrue _) (PTrue _) = return [] + match (PTrue _ _) (PTrue _ _) = return [] match (PFalse _) (PFalse _) = return [] match (PReturn _) (PReturn _) = return [] match (PPi _ _ t s) (PPi _ _ t' s') = do mt <- match' t t' @@ -1540,7 +1647,7 @@ sm xs (PRewrite f x y tm) = PRewrite f (sm xs x) (sm xs y) (fmap (sm xs) tm) 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 (PPair f p x y) = PPair f p (sm xs x) (sm xs y) sm xs (PDPair f x t y) = PDPair f (sm xs x) (sm xs t) (sm xs y) sm xs (PAlternative a as) = PAlternative a (map (sm xs) as) sm xs (PHidden x) = PHidden (sm xs x) @@ -1554,19 +1661,100 @@ shadow :: Name -> Name -> PTerm -> PTerm shadow n n' t = sm t where sm (PRef fc x) | n == x = PRef fc n' - sm (PLam x t sc) = PLam x (sm t) (sm sc) - sm (PPi p x t sc) = PPi p x (sm t) (sm sc) + sm (PLam x t sc) | n /= x = PLam x (sm t) (sm sc) + sm (PPi p x t sc) | n /=x = PPi p x (sm t) (sm sc) + sm (PLet x t v sc) | n /= x = PLet x (sm t) (sm v) (sm sc) sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as) + sm (PAppBind f x as) = PAppBind 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 tm) = PRewrite f (sm x) (sm y) (fmap sm tm) sm (PTyped x y) = PTyped (sm x) (sm y) - sm (PPair f x y) = PPair f (sm x) (sm y) + sm (PPair f p x y) = PPair f p (sm x) (sm y) sm (PDPair f x t y) = PDPair f (sm x) (sm t) (sm y) sm (PAlternative a as) = PAlternative a (map sm as) + sm (PTactics ts) = PTactics (map (fmap sm) ts) + sm (PProof ts) = PProof (map (fmap sm) ts) sm (PHidden x) = PHidden (sm x) sm (PUnifyLog x) = PUnifyLog (sm x) sm (PNoImplicits x) = PNoImplicits (sm x) sm x = x + +-- Rename any binders which are repeated (so that we don't have to mess +-- about with shadowing anywhere else). + +mkUniqueNames :: [Name] -> PTerm -> PTerm +mkUniqueNames env tm = evalState (mkUniq tm) env where + inScope = boundNamesIn tm + + mkUniqA arg = do t' <- mkUniq (getTm arg) + return (arg { getTm = t' }) + + -- FIXME: Probably ought to do this for completeness! It's fine as + -- long as there are no bindings inside tactics though. + mkUniqT tac = return tac + + mkUniq :: PTerm -> State [Name] PTerm + mkUniq (PLam n ty sc) + = do env <- get + (n', sc') <- + if n `elem` env + then do let n' = uniqueName n (env ++ inScope) + return (n', shadow n n' sc) + else return (n, sc) + put (n' : env) + ty' <- mkUniq ty + sc'' <- mkUniq sc' + return $! PLam n' ty' sc'' + mkUniq (PPi p n ty sc) + = do env <- get + (n', sc') <- + if n `elem` env + then do let n' = uniqueName n (env ++ inScope) + return (n', shadow n n' sc) + else return (n, sc) + put (n' : env) + ty' <- mkUniq ty + sc'' <- mkUniq sc' + return $! PPi p n' ty' sc'' + mkUniq (PLet n ty val sc) + = do env <- get + (n', sc') <- + if n `elem` env + then do let n' = uniqueName n (env ++ inScope) + return (n', shadow n n' sc) + else return (n, sc) + put (n' : env) + ty' <- mkUniq ty; val' <- mkUniq val + sc'' <- mkUniq sc' + return $! PLet n' ty' val' sc'' + mkUniq (PApp fc t args) + = do t' <- mkUniq t + args' <- mapM mkUniqA args + return $! PApp fc t' args' + mkUniq (PAppBind fc t args) + = do t' <- mkUniq t + args' <- mapM mkUniqA args + return $! PAppBind fc t' args' + mkUniq (PCase fc t alts) + = do t' <- mkUniq t + alts' <- mapM (\(x,y)-> do x' <- mkUniq x; y' <- mkUniq y + return (x', y')) alts + return $! PCase fc t' alts' + mkUniq (PPair fc p l r) + = do l' <- mkUniq l; r' <- mkUniq r + return $! PPair fc p l' r' + mkUniq (PDPair fc l t r) + = do l' <- mkUniq l; t' <- mkUniq t; r' <- mkUniq r + return $! PDPair fc l' t' r' + mkUniq (PAlternative b as) + = liftM (PAlternative b) (mapM mkUniq as) + mkUniq (PHidden t) = liftM PHidden (mkUniq t) + mkUniq (PUnifyLog t) = liftM PUnifyLog (mkUniq t) + mkUniq (PDisamb n t) = liftM (PDisamb n) (mkUniq t) + mkUniq (PNoImplicits t) = liftM PNoImplicits (mkUniq t) + mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts) + mkUniq (PTactics ts) = liftM PTactics (mapM mkUniqT ts) + mkUniq t = return t diff --git a/src/Idris/AbsSyntaxTree.hs b/src/Idris/AbsSyntaxTree.hs --- a/src/Idris/AbsSyntaxTree.hs +++ b/src/Idris/AbsSyntaxTree.hs @@ -3,10 +3,10 @@ module Idris.AbsSyntaxTree where -import Core.TT -import Core.Evaluate -import Core.Elaborate hiding (Tactic(..)) -import Core.Typecheck +import Idris.Core.TT +import Idris.Core.Evaluate +import Idris.Core.Elaborate hiding (Tactic(..)) +import Idris.Core.Typecheck import IRTS.Lang import IRTS.CodegenCommon import Util.Pretty @@ -22,13 +22,19 @@ import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Error -import Data.List +import Data.List hiding (group) import Data.Char +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Map as M import Data.Either +import qualified Data.Set as S import Data.Word (Word) import Debug.Trace +import Text.PrettyPrint.Annotated.Leijen + data IOption = IOption { opt_logLevel :: Int, opt_typecase :: Bool, opt_typeintype :: Bool, @@ -46,7 +52,8 @@ opt_triple :: String, opt_cpu :: String, opt_optLevel :: Word, - opt_cmdline :: [Opt] -- remember whole command line + opt_cmdline :: [Opt], -- remember whole command line + opt_origerr :: Bool } deriving (Show, Eq) @@ -68,6 +75,7 @@ , opt_cpu = "" , opt_optLevel = 2 , opt_cmdline = [] + , opt_origerr = False } data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord) @@ -75,6 +83,11 @@ -- | The output mode in use data OutputMode = RawOutput | IdeSlave Integer deriving Show +-- | How wide is the console? +data ConsoleWidth = InfinitelyWide -- ^ Have pretty-printer assume that lines should not be broken + | ColsWide Int -- ^ Manually specified - must be positive + | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise + -- 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 @@ -108,6 +121,7 @@ idris_metavars :: [(Name, (Maybe Name, Int, Bool))], -- ^ The currently defined but not proven metavariables idris_coercions :: [Name], idris_transforms :: [(Term, Term)], + idris_errRev :: [(Term, Term)], syntax_rules :: [Syntax], syntax_keywords :: [String], imported :: [FilePath], -- ^ The imported modules @@ -131,7 +145,12 @@ idris_outputmode :: OutputMode, idris_colourRepl :: Bool, idris_colourTheme :: ColourTheme, - idris_outh :: Handle + idris_outh :: Handle, + idris_errorhandlers :: [Name], -- ^ Global error handlers + idris_nameIdx :: (Int, Ctxt (Int, Name)), + idris_function_errorhandlers :: Ctxt (M.Map Name (S.Set Name)), -- ^ Specific error handlers + module_aliases :: M.Map [T.Text] [T.Text], + idris_consolewidth :: ConsoleWidth -- ^ How many chars wide is the console? } data SizeChange = Smaller | Same | Bigger | Unknown @@ -154,10 +173,10 @@ deriving instance NFData CGInfo !-} -primDefs = [UN "unsafePerformPrimIO", - UN "mkLazyForeignPrim", - UN "mkForeignPrim", - UN "FalseElim"] +primDefs = [sUN "unsafePerformPrimIO", + sUN "mkLazyForeignPrim", + sUN "mkForeignPrim", + sUN "FalseElim"] -- information that needs writing for the current module's .ibc file data IBCWrite = IBCFix FixDecl @@ -177,24 +196,31 @@ | IBCDyLib String | IBCHeader Codegen String | IBCAccess Name Accessibility + | IBCMetaInformation Name MetaInformation | IBCTotal Name Totality | IBCFlags Name [FnOpt] | IBCTrans (Term, Term) + | IBCErrRev (Term, Term) | IBCCG Name | IBCDoc Name | IBCCoercion Name | IBCDef Name -- i.e. main context | IBCNameHint (Name, Name) | IBCLineApp FilePath Int PTerm + | IBCErrorHandler Name + | IBCFunctionErrorHandler Name Name Name deriving Show +-- | The initial state for the compiler +idrisInit :: IState idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext - [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] + [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput - True defaultTheme stdout + True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty + AutomaticWidth -- | The monad for the main REPL - reading and processing files and updating -- global state (hence the IO inner monad). @@ -257,6 +283,8 @@ | SetColour ColourType IdrisColour | ColourOn | ColourOff + | ListErrorHandlers + | SetConsoleWidth ConsoleWidth data Opt = Filename String | Ver @@ -288,6 +316,8 @@ | PkgBuild String | PkgInstall String | PkgClean String + | PkgCheck String + | PkgREPL String | WarnOnly | Pkg String | BCAsm String @@ -301,6 +331,8 @@ | TargetCPU String | OptLevel Word | Client String + | ShowOrigErr + | AutoWidth -- ^ Automatically adjust terminal width deriving (Show, Eq) -- Parsed declarations @@ -344,33 +376,36 @@ !-} -- Mark bindings with their explicitness, and laziness -data Plicity = Imp { plazy :: Bool, +data Plicity = Imp { pargopts :: [ArgOpt], pstatic :: Static, pdocstr :: String, pparam :: Bool } - | Exp { plazy :: Bool, + | Exp { pargopts :: [ArgOpt], pstatic :: Static, pdocstr :: String, pparam :: Bool } - | Constraint { plazy :: Bool, + | Constraint { pargopts :: [ArgOpt], pstatic :: Static, pdocstr :: String } - | TacImp { plazy :: Bool, + | TacImp { pargopts :: [ArgOpt], pstatic :: Static, pscript :: PTerm, pdocstr :: String } deriving (Show, Eq) +plazy :: Plicity -> Bool +plazy tm = Lazy `elem` pargopts tm + {-! deriving instance Binary Plicity deriving instance NFData Plicity !-} -impl = Imp False Dynamic "" False -expl = Exp False Dynamic "" False -expl_param = Exp False Dynamic "" True -constraint = Constraint False Dynamic "" -tacimpl t = TacImp False Dynamic t "" +impl = Imp [Lazy] Dynamic "" False +expl = Exp [] Dynamic "" False +expl_param = Exp [] Dynamic "" True +constraint = Constraint [] Dynamic "" +tacimpl t = TacImp [] Dynamic t "" data FnOpt = Inlinable -- always evaluate when simplifying | TotalFn | PartialFn @@ -379,6 +414,8 @@ -- a function argument, and further evaluation resutls | Implicit -- implicit coercion | CExport String -- export, with a C name + | ErrorHandler -- ^^ an error handler for use with the ErrorReflection extension + | ErrorReverse -- ^^ attempt to reverse normalise before showing in error | Reflection -- a reflecting function, compile-time only | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names deriving (Show, Eq) @@ -399,6 +436,7 @@ -- | Data declaration options data DataOpt = Codata -- Set if the the data-type is coinductive | DefaultEliminator -- Set if an eliminator should be generated for data type + | DataErrRev deriving (Show, Eq) type DataOpts = [DataOpt] @@ -469,7 +507,7 @@ -- | Data declaration data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype d_tcon :: t, -- ^ Type constructor - d_cons :: [(String, Name, t, FC)] -- ^ Constructors + d_cons :: [(String, Name, t, FC, [Name])] -- ^ Constructors } -- ^ Data declaration | PLaterdecl { d_name :: Name, d_tcon :: t } @@ -496,7 +534,7 @@ declared (PClauses _ _ n _) = [] -- not a declaration declared (PCAF _ n _) = [n] declared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts - where fstt (_, a, _, _) = a + where fstt (_, a, _, _, _) = a declared (PData _ _ _ _ (PLaterdecl n _)) = [n] declared (PParams _ _ ds) = concatMap declared ds declared (PNamespace _ ds) = concatMap declared ds @@ -516,7 +554,7 @@ tldeclared (PClauses _ _ n _) = [] -- not a declaration tldeclared (PRecord _ _ _ n _ _ c _) = [n, c] tldeclared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts - where fstt (_, a, _, _) = a + where fstt (_, a, _, _, _) = a tldeclared (PParams _ _ ds) = [] tldeclared (PMutual _ ds) = concatMap tldeclared ds tldeclared (PNamespace _ ds) = concatMap tldeclared ds @@ -531,7 +569,7 @@ defined (PClauses _ _ n _) = [n] -- not a declaration defined (PCAF _ n _) = [n] defined (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts - where fstt (_, a, _, _) = a + where fstt (_, a, _, _, _) = a defined (PData _ _ _ _ (PLaterdecl n _)) = [] defined (PParams _ _ ds) = concatMap defined ds defined (PNamespace _ ds) = concatMap defined ds @@ -565,6 +603,8 @@ -- (map (updateDNs ns) ds) -- updateDNs ns c = c +data PunInfo = IsType | IsTerm | TypeOrTerm deriving (Eq, Show) + -- | High level language terms data PTerm = PQuote Raw | PRef FC Name @@ -578,13 +618,13 @@ | PAppBind FC PTerm [PArg] -- ^ implicitly bound application | PMatchApp FC Name -- ^ Make an application by type matching | PCase FC PTerm [(PTerm, PTerm)] - | PTrue FC + | PTrue FC PunInfo | PFalse FC | PRefl FC PTerm | PResolveTC FC | PEq FC PTerm PTerm | PRewrite FC PTerm PTerm (Maybe PTerm) - | PPair FC PTerm PTerm + | PPair FC PunInfo PTerm PTerm | PDPair FC PTerm PTerm PTerm | PAlternative Bool [PTerm] -- True if only one may work | PHidden PTerm -- ^ Irrelevant or hidden pattern @@ -601,6 +641,7 @@ | PElabError Err -- ^ Error to report on elaboration | PImpossible -- ^ Special case for declaring when an LHS can't typecheck | PCoerced PTerm -- ^ To mark a coerced argument, so as not to coerce twice + | PDisamb [[T.Text]] PTerm -- ^ Preferences for explicit namespaces | PUnifyLog PTerm -- ^ dump a trace of unifications when building term | PNoImplicits PTerm -- ^ never run implicit converions on the term deriving Eq @@ -623,7 +664,7 @@ 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) mpt (PTyped l r) = PTyped (mapPT f l) (mapPT f r) - mpt (PPair fc l r) = PPair fc (mapPT f l) (mapPT f r) + mpt (PPair fc p l r) = PPair fc p (mapPT f l) (mapPT f r) mpt (PDPair fc l t r) = PDPair fc (mapPT f l) (mapPT f t) (mapPT f r) mpt (PAlternative a as) = PAlternative a (map (mapPT f) as) mpt (PHidden t) = PHidden (mapPT f t) @@ -631,6 +672,7 @@ mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts) mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts) mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm) + mpt (PDisamb ns tm) = PDisamb ns (mapPT f tm) mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm) mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc) mpt x = x @@ -638,10 +680,11 @@ data PTactic' t = Intro [Name] | Intros | Focus Name | Refine Name [Bool] | Rewrite t + | Induction Name | Equiv t | MatchRefine Name | LetTac Name t | LetTacTy Name t t - | Exact t | Compute | Trivial + | Exact t | Compute | Trivial | TCInstance | ProofSearch (Maybe Name) Name [Name] | Solve | Attack @@ -649,6 +692,7 @@ | Try (PTactic' t) (PTactic' t) | TSeq (PTactic' t) (PTactic' t) | ApplyTactic t -- see Language.Reflection module + | ByReflection t | Reflect t | Fill t | GoalType String (PTactic' t) @@ -658,13 +702,13 @@ deriving instance Binary PTactic' deriving instance NFData PTactic' !-} - instance Sized a => Sized (PTactic' a) where size (Intro nms) = 1 + size nms size Intros = 1 size (Focus nm) = 1 + size nm size (Refine nm bs) = 1 + size nm + length bs size (Rewrite t) = 1 + size t + size (Induction t) = 1 + size t size (LetTac nm t) = 1 + size nm + size t size (Exact t) = 1 + size t size Compute = 1 @@ -710,21 +754,31 @@ data PArg' t = PImp { priority :: Int, machine_inf :: Bool, -- true if the machine inferred it - lazyarg :: Bool, pname :: Name, getTm :: t, + argopts :: [ArgOpt], + pname :: Name, getTm :: t, pargdoc :: String } | PExp { priority :: Int, - lazyarg :: Bool, getTm :: t, + argopts :: [ArgOpt], + getTm :: t, pargdoc :: String } | PConstraint { priority :: Int, - lazyarg :: Bool, getTm :: t, + argopts :: [ArgOpt], + getTm :: t, pargdoc :: String } | PTacImplicit { priority :: Int, - lazyarg :: Bool, pname :: Name, + argopts :: [ArgOpt], + pname :: Name, getScript :: t, getTm :: t, pargdoc :: String } deriving (Show, Eq, Functor) +data ArgOpt = Lazy | HideDisplay + deriving (Show, Eq) + +lazyarg :: PArg' t -> Bool +lazyarg tm = Lazy `elem` argopts tm + instance Sized a => Sized (PArg' a) where size (PImp p _ l nm trm _) = 1 + size nm + size trm size (PExp p l trm _) = 1 + size trm @@ -736,10 +790,10 @@ deriving instance NFData PArg' !-} -pimp n t mach = PImp 1 mach True n t "" -pexp t = PExp 1 False t "" -pconst t = PConstraint 1 False t "" -ptacimp n s t = PTacImplicit 0 True n s t "" +pimp n t mach = PImp 1 mach [Lazy] n t "" +pexp t = PExp 1 [] t "" +pconst t = PConstraint 1 [] t "" +ptacimp n s t = PTacImplicit 2 [Lazy] n s t "" type PArg = PArg' PTerm @@ -748,6 +802,7 @@ data ClassInfo = CI { instanceName :: Name, class_methods :: [(Name, (FnOpts, PTerm))], class_defaults :: [(Name, (Name, PDecl))], -- method name -> default impl + class_default_superclasses :: [PDecl], class_params :: [Name], class_instances :: [Name] } deriving Show @@ -756,9 +811,21 @@ deriving instance NFData ClassInfo !-} +-- An argument is conditionally forceable iff its forceability +-- depends on the collapsibility of the whole type. +data Forceability = Conditional | Unconditional deriving (Show, Enum, Bounded, Eq, Ord) + +{-! +deriving instance Binary Forceability +deriving instance NFData Forceability +!-} + data OptInfo = Optimise { collapsible :: Bool, isnewtype :: Bool, - forceable :: [Int], -- argument positions + -- The following should actually be (IntMap Forceability) + -- but the corresponding Binary instance seems to be broken. + -- Let's store a list and convert it to IntMap whenever needed. + forceable :: [(Int, Forceability)], recursive :: [Int] } deriving Show {-! @@ -769,6 +836,7 @@ data TypeInfo = TI { con_names :: [Name], codata :: Bool, + data_opts :: DataOpts, param_pos :: [Int] } deriving Show {-! @@ -821,10 +889,10 @@ deriving instance NFData SSymbol !-} -initDSL = DSL (PRef f (UN ">>=")) - (PRef f (UN "return")) - (PRef f (UN "<$>")) - (PRef f (UN "pure")) +initDSL = DSL (PRef f (sUN ">>=")) + (PRef f (sUN "return")) + (PRef f (sUN "<$>")) + (PRef f (sUN "pure")) Nothing Nothing Nothing @@ -860,277 +928,425 @@ expandNS syn n@(NS _ _) = n expandNS syn n = case syn_namespace syn of [] -> n - xs -> NS n xs + xs -> sNS n xs ---- Pretty printing declarations and terms +-- For inferring types of things -instance Show PTerm where - show tm = showImp Nothing False False tm +bi = fileFC "builtin" -instance Pretty PTerm where - pretty = prettyImp False +inferTy = sMN 0 "__Infer" +inferCon = sMN 0 "__infer" +inferDecl = PDatadecl inferTy + PType + [("", inferCon, PPi impl (sMN 0 "iType") PType ( + PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType")) + (PRef bi inferTy)), bi, [])] +inferOpts = [] -instance Show PDecl where - show d = showDeclImp False d +infTerm t = PApp bi (PRef bi inferCon) [pimp (sMN 0 "iType") Placeholder True, pexp t] +infP = P (TCon 6 0) inferTy (TType (UVal 0)) -instance Show PClause where - show c = showCImp True c +getInferTerm, getInferType :: Term -> Term +getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc +getInferTerm (App (App _ _) tm) = tm +getInferTerm tm = tm -- error ("getInferTerm " ++ show tm) -instance Show PData where - show d = showDImp False d +getInferType (Bind n b sc) = Bind n b $ getInferType sc +getInferType (App (App _ ty) _) = ty -showDecls :: Bool -> [PDecl] -> String -showDecls _ [] = "" -showDecls i (d:ds) = showDeclImp i d ++ "\n" ++ showDecls i ds -showDeclImp _ (PFix _ f ops) = show f ++ " " ++ showSep ", " ops -showDeclImp i (PTy _ _ _ _ n t) = "tydecl " ++ showCG n ++ " : " ++ showImp Nothing i False t -showDeclImp i (PClauses _ _ n cs) = "pat " ++ showCG n ++ "\t" ++ showSep "\n\t" (map (showCImp i) cs) -showDeclImp _ (PData _ _ _ _ d) = showDImp True d -showDeclImp i (PParams _ ns ps) = "params {" ++ show ns ++ "\n" ++ showDecls i ps ++ "}\n" -showDeclImp i (PNamespace n ps) = "namespace {" ++ n ++ "\n" ++ showDecls i ps ++ "}\n" -showDeclImp _ (PSyntax _ syn) = "syntax " ++ show syn -showDeclImp i (PClass _ _ _ cs n ps ds) - = "class " ++ show cs ++ " " ++ show n ++ " " ++ show ps ++ "\n" ++ showDecls i ds -showDeclImp i (PInstance _ _ cs n _ t _ ds) - = "instance " ++ show cs ++ " " ++ show n ++ " " ++ show t ++ "\n" ++ showDecls i ds -showDeclImp _ _ = "..." --- showDeclImp (PImport i) = "import " ++ i +-- Handy primitives: Unit, False, Pair, MkPair, =, mkForeign, Elim type class -showCImp :: Bool -> PClause -> String -showCImp impl (PClause _ n l ws r w) - = showImp Nothing impl False l ++ showWs ws ++ " = " ++ showImp Nothing impl False r - ++ " where " ++ show w - where - showWs [] = "" - showWs (x : xs) = " | " ++ showImp Nothing impl False x ++ showWs xs -showCImp impl (PWith _ n l ws r w) - = showImp Nothing impl False l ++ showWs ws ++ " with " ++ showImp Nothing impl False r - ++ " { " ++ show w ++ " } " - where - showWs [] = "" - showWs (x : xs) = " | " ++ showImp Nothing impl False x ++ showWs xs +primNames = [unitTy, unitCon, + falseTy, pairTy, pairCon, + eqTy, eqCon, inferTy, inferCon] +unitTy = sMN 0 "__Unit" +unitCon = sMN 0 "__II" +unitDecl = PDatadecl unitTy PType + [("", unitCon, PRef bi unitTy, bi, [])] +unitOpts = [DefaultEliminator] -showDImp :: Bool -> PData -> String -showDImp impl (PDatadecl n ty cons) - = "data " ++ show n ++ " : " ++ showImp Nothing impl False ty ++ " where\n\t" - ++ showSep "\n\t| " - (map (\ (_, n, t, _) -> show n ++ " : " ++ showImp Nothing impl False t) cons) +falseTy = sMN 0 "__False" +falseDecl = PDatadecl falseTy PType [] +falseOpts = [] -getImps :: [PArg] -> [(Name, PTerm)] -getImps [] = [] -getImps (PImp _ _ _ n tm _ : xs) = (n, tm) : getImps xs -getImps (_ : xs) = getImps xs +pairTy = sMN 0 "__Pair" +pairCon = sMN 0 "__MkPair" +pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType) + [("", pairCon, PPi impl (n "A") PType ( + PPi impl (n "B") PType ( + PPi expl (n "a") (PRef bi (n "A")) ( + PPi expl (n "b") (PRef bi (n "B")) + (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")), + pexp (PRef bi (n "B"))])))), bi, [])] + where n a = sMN 0 a +pairOpts = [] -getExps :: [PArg] -> [PTerm] -getExps [] = [] -getExps (PExp _ _ tm _ : xs) = tm : getExps xs -getExps (_ : xs) = getExps xs +eqTy = sUN "=" +eqCon = sUN "refl" +eqDecl = PDatadecl eqTy (piBind [(n "A", PType), (n "B", PType), + (n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))] + PType) + [("", eqCon, PPi impl (n "A") PType ( + PPi impl (n "x") (PRef bi (n "A")) + (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False, + pimp (n "B") Placeholder False, + pexp (PRef bi (n "x")), + pexp (PRef bi (n "x"))])), bi, [])] + where n a = sMN 0 a +eqOpts = [] -getConsts :: [PArg] -> [PTerm] -getConsts [] = [] -getConsts (PConstraint _ _ tm _ : xs) = tm : getConsts xs -getConsts (_ : xs) = getConsts xs +elimName = sUN "__Elim" +elimMethElimTy = sUN "__elimTy" +elimMethElim = sUN "elim" +elimDecl = PClass "Type class for eliminators" defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)] + [PTy "" defaultSyntax bi [TotalFn] elimMethElimTy PType, + PTy "" defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)] -getAll :: [PArg] -> [PTerm] -getAll = map getTm +-- Defined in builtins.idr +sigmaTy = sUN "Exists" +existsCon = sUN "Ex_intro" --- | Pretty-print a high-level Idris term +piBind :: [(Name, PTerm)] -> PTerm -> PTerm +piBind = piBindp expl + +piBindp :: Plicity -> [(Name, PTerm)] -> PTerm -> PTerm +piBindp p [] t = t +piBindp p ((n, ty):ns) t = PPi p n ty (piBindp p ns t) + + +-- Pretty-printing declarations and terms + +-- These "show" instances render to an absurdly wide screen because inserted line breaks +-- could interfere with interactive editing, which calls "show". + +instance Show PTerm where + showsPrec _ tm = (displayS . renderPretty 1.0 10000000 . prettyImp False) tm + +instance Show PDecl where + showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDeclImp False) d + +instance Show PClause where + showsPrec _ c = (displayS . renderPretty 1.0 10000000 . showCImp True) c + +instance Show PData where + showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDImp False) d + +instance Pretty PTerm OutputAnnotation where + pretty = prettyImp False + +-- | Colourise annotations according to an Idris state. It ignores the names +-- in the annotation, as there's no good way to show extended information on a +-- terminal. +consoleDecorate :: IState -> OutputAnnotation -> String -> String +consoleDecorate ist _ | not (idris_colourRepl ist) = id +consoleDecorate ist AnnConstData = let theme = idris_colourTheme ist + in colouriseData theme +consoleDecorate ist AnnConstType = let theme = idris_colourTheme ist + in colouriseType theme +consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist) +consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist) +consoleDecorate ist (AnnName n _ _) = let ctxt = tt_ctxt ist + theme = idris_colourTheme ist + in case () of + _ | isDConName n ctxt -> colouriseData theme + _ | isFnName n ctxt -> colouriseFun theme + _ | isTConName n ctxt -> colouriseType theme + _ | otherwise -> id -- don't colourise unknown names +consoleDecorate ist (AnnFC _) = id + +-- | Pretty-print a high-level closed Idris term prettyImp :: Bool -- ^^ whether to show implicits -> PTerm -- ^^ the term to pretty-print - -> Doc -prettyImp impl = prettySe 10 + -> Doc OutputAnnotation +prettyImp impl = pprintPTerm impl [] + +-- | Pretty-print a high-level Idris term in some bindings context +pprintPTerm :: Bool -- ^^ whether to show implicits + -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit + -> PTerm -- ^^ the term to pretty-print + -> Doc OutputAnnotation +pprintPTerm impl bnd = prettySe 10 bnd where - prettySe p (PQuote r) = - if size r > breakingSize then - text "![" $$ pretty r <> text "]" - else + prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation + prettySe p bnd (PQuote r) = text "![" <> pretty r <> text "]" - prettySe p (PPatvar fc n) = pretty n - prettySe p (PRef fc n) = - if impl then - pretty n - else - prettyBasic n - where - prettyBasic n@(UN _) = pretty n - prettyBasic (MN _ s) = text s - prettyBasic (NS n s) = (foldr (<>) empty (intersperse (text ".") (map text $ reverse s))) <> prettyBasic n - prettyBasic (SN sn) = text (show sn) - prettySe p (PLam n ty sc) = - bracket p 2 $ - if size sc > breakingSize then - text "λ" <> pretty n <+> text "=>" $+$ pretty sc - else - text "λ" <> pretty n <+> text "=>" <+> pretty sc - prettySe p (PLet n ty v sc) = + prettySe p bnd (PPatvar fc n) = pretty n + prettySe p bnd e + | Just str <- slist p bnd e = str + | Just n <- snat p e = annotate AnnConstData (text (show n)) + prettySe p bnd (PRef fc n) = prettyName impl bnd n + prettySe p bnd (PLam n ty sc) = + bracket p 2 . group . align . hang 2 $ + text "\\" <> bindingOf n False <+> text "=>" <$> + prettySe 10 ((n, False):bnd) sc + prettySe p bnd (PLet n ty v sc) = bracket p 2 $ - if size sc > breakingSize then - text "let" <+> pretty n <+> text "=" <+> prettySe 10 v <+> text "in" $+$ - nest nestingSize (prettySe 10 sc) - else - text "let" <+> pretty n <+> text "=" <+> prettySe 10 v <+> text "in" <+> - prettySe 10 sc - prettySe p (PPi (Exp l s _ _) n ty sc) + text "let" <+> bindingOf n False <+> text "=" + prettySe 10 bnd v <+> text "in" + prettySe 10 ((n, False):bnd) sc + prettySe p bnd (PPi (Exp l s _ _) n ty sc) | n `elem` allNamesIn sc || impl = - let open = if l then text "|" <> lparen else lparen in - bracket p 2 $ - if size sc > breakingSize then - open <> pretty n <+> colon <+> prettySe 10 ty <> rparen <+> - st <+> text "->" $+$ prettySe 10 sc - else - open <> pretty n <+> colon <+> prettySe 10 ty <> rparen <+> - st <+> text "->" <+> prettySe 10 sc + let open = if Lazy `elem` l then text "|" <> lparen else lparen in + bracket p 2 . group $ + enclose open rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+> + st <> text "->" <$> prettySe 10 ((n, False):bnd) sc | otherwise = - bracket p 2 $ - if size sc > breakingSize then - prettySe 0 ty <+> st <+> text "->" $+$ prettySe 10 sc - else - prettySe 0 ty <+> st <+> text "->" <+> prettySe 10 sc + bracket p 2 . group $ + group (prettySe 0 bnd ty <+> st) <> text "->" <$> group (prettySe 10 ((n, False):bnd) sc) where st = case s of - Static -> text "[static]" + Static -> text "[static]" <> space _ -> empty - prettySe p (PPi (Imp l s _ _) n ty sc) + prettySe p bnd (PPi (Imp l s _ _) n ty sc) | impl = - let open = if l then text "|" <> lbrace else lbrace in + let open = if Lazy `elem` l then text "|" <> lbrace else lbrace in bracket p 2 $ - if size sc > breakingSize then - open <> pretty n <+> colon <+> prettySe 10 ty <> rbrace <+> - st <+> text "->" <+> prettySe 10 sc - else - open <> pretty n <+> colon <+> prettySe 10 ty <> rbrace <+> - st <+> text "->" <+> prettySe 10 sc - | otherwise = prettySe 10 sc + open <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+> + st <> text "->" prettySe 10 ((n, True):bnd) sc + | otherwise = prettySe 10 ((n, True):bnd) sc where st = case s of - Static -> text $ "[static]" + Static -> text "[static]" <> space _ -> empty - prettySe p (PPi (Constraint _ _ _) n ty sc) = + prettySe p bnd (PPi (Constraint _ _ _) n ty sc) = bracket p 2 $ - if size sc > breakingSize then - prettySe 10 ty <+> text "=>" <+> prettySe 10 sc - else - prettySe 10 ty <+> text "=>" $+$ prettySe 10 sc - prettySe p (PPi (TacImp _ _ s _) n ty sc) = + prettySe 10 bnd ty <+> text "=>" prettySe 10 ((n, True):bnd) sc + prettySe p bnd (PPi (TacImp _ _ s _) n ty sc) = bracket p 2 $ - if size sc > breakingSize then - lbrace <> text "tacimp" <+> pretty n <+> colon <+> prettySe 10 ty <> - rbrace <+> text "->" $+$ prettySe 10 sc - else - lbrace <> text "tacimp" <+> pretty n <+> colon <+> prettySe 10 ty <> - rbrace <+> text "->" <+> prettySe 10 sc - prettySe p (PApp _ (PRef _ f) []) - | not impl = pretty f - prettySe p (PAppBind _ (PRef _ f) []) - | not impl = text "!" <+> pretty f - prettySe p (PApp _ (PRef _ op@(UN (f:_))) args) - | length (getExps args) == 2 && (not impl) && (not $ isAlpha f) = + lbrace <> text "tacimp" <+> pretty n <+> colon <+> prettySe 10 bnd ty <> + rbrace <+> text "->" prettySe 10 ((n, True):bnd) sc + prettySe p bnd (PApp _ (PRef _ f) []) + | not impl = prettyName impl bnd f + prettySe p bnd (PAppBind _ (PRef _ f) []) + | not impl = text "!" <> prettyName impl bnd f + prettySe p bnd (PApp _ (PRef _ op) args) + | UN nm <- basename op + , not (tnull nm) && + length (getExps args) == 2 && (not impl) && (not $ isAlpha (thead nm)) = let [l, r] = getExps args in - bracket p 1 $ - if size r > breakingSize then - prettySe 1 l <+> pretty op $+$ prettySe 0 r - else - prettySe 1 l <+> pretty op <+> prettySe 0 r - prettySe p (PApp _ f as) = - let args = getExps as in - bracket p 1 $ - prettySe 1 f <+> - if impl then - foldl' fS empty as - -- foldr (<+>) empty $ map prettyArgS as - else - foldl' fSe empty args - -- foldr (<+>) empty $ map prettyArgSe args - where - fS l r = - if size r > breakingSize then - l $+$ nest nestingSize (prettyArgS r) - else - l <+> prettyArgS r - - fSe l r = - if size r > breakingSize then - l $+$ nest nestingSize (prettyArgSe r) - else - l <+> prettyArgSe r - prettySe p (PCase _ scr opts) = - text "case" <+> prettySe 10 scr <+> text "of" $+$ nest nestingSize prettyBody + bracket p 1 . align . group $ + (prettySe 1 bnd l <+> prettyName impl bnd op) <$> group (prettySe 0 bnd r) + prettySe p bnd (PApp _ hd@(PRef fc f) [tm]) + | PConstant (Idris.Core.TT.Str str) <- getTm tm, + f == sUN "Symbol_" = char '\'' <> prettySe 10 bnd (PRef fc (sUN str)) + prettySe p bnd (PApp _ f as) = + let args = getExps as + fp = prettySe 1 bnd f + in + bracket p 1 . group $ + if impl + then if null as + then fp + else fp <+> align (vsep (map (prettyArgS bnd) as)) + else if null args + then fp + else fp <+> align (vsep (map (prettyArgSe bnd) args)) + prettySe p bnd (PCase _ scr opts) = + text "case" <+> prettySe 10 bnd scr <+> text "of" <> prettyBody where - prettyBody = foldr ($$) empty $ intersperse (text "|") $ map sc opts + prettyBody = foldr (<>) empty $ intersperse (text "|") $ map sc opts - sc (l, r) = prettySe 10 l <+> text "=>" <+> prettySe 10 r - prettySe p (PHidden tm) = text "." <> prettySe 0 tm - prettySe p (PRefl _ _) = text "refl" - prettySe p (PResolveTC _) = text "resolvetc" - prettySe p (PTrue _) = text "()" - prettySe p (PFalse _) = text "_|_" - prettySe p (PEq _ l r) = - bracket p 2 $ - if size r > breakingSize then - prettySe 10 l <+> text "=" $$ nest nestingSize (prettySe 10 r) - else - prettySe 10 l <+> text "=" <+> prettySe 10 r - prettySe p (PRewrite _ l r _) = + sc (l, r) = nest nestingSize $ prettySe 10 bnd l <+> text "=>" <+> prettySe 10 bnd r + prettySe p bnd (PHidden tm) = text "." <> prettySe 0 bnd tm + prettySe p bnd (PRefl _ _) = annotate (AnnName eqCon Nothing Nothing) $ text "refl" + prettySe p bnd (PResolveTC _) = text "resolvetc" + prettySe p bnd (PTrue _ IsType) = annotate (AnnName unitTy Nothing Nothing) $ text "()" + prettySe p bnd (PTrue _ IsTerm) = annotate (AnnName unitCon Nothing Nothing) $ text "()" + prettySe p bnd (PTrue _ TypeOrTerm) = text "()" + prettySe p bnd (PFalse _) = annotate (AnnName falseTy Nothing Nothing) $ text "_|_" + prettySe p bnd (PEq _ l r) = + bracket p 2 . align . group $ + prettySe 10 bnd l <+> eq <$> group (prettySe 10 bnd r) + where eq = annotate (AnnName eqTy Nothing Nothing) (text "=") + prettySe p bnd (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) = - if size r > breakingSize then - lparen <> prettySe 10 l <> text "," $+$ - prettySe 10 r <> rparen - else - lparen <> prettySe 10 l <> text "," <+> prettySe 10 r <> rparen - prettySe p (PDPair _ l t r) = - if size r > breakingSize then - lparen <> prettySe 10 l <+> text "**" $+$ - prettySe 10 r <> rparen - else - lparen <> prettySe 10 l <+> text "**" <+> prettySe 10 r <> rparen - prettySe p (PAlternative a as) = + text "rewrite" <+> prettySe 10 bnd l <+> text "in" <+> prettySe 10 bnd r + prettySe p bnd (PTyped l r) = + lparen <> prettySe 10 bnd l <+> colon <+> prettySe 10 bnd r <> rparen + prettySe p bnd (PPair _ TypeOrTerm l r) = + lparen <> prettySe 10 bnd l <> text "," <+> prettySe 10 bnd r <> rparen + prettySe p bnd (PPair _ IsType l r) = + annotate (AnnName pairTy Nothing Nothing) lparen <> + prettySe 10 bnd l <> + annotate (AnnName pairTy Nothing Nothing) comma <+> + prettySe 10 bnd r <> + annotate (AnnName pairTy Nothing Nothing) rparen + prettySe p bnd (PPair _ IsTerm l r) = + annotate (AnnName pairCon Nothing Nothing) lparen <> + prettySe 10 bnd l <> + annotate (AnnName pairCon Nothing Nothing) comma <+> + prettySe 10 bnd r <> + annotate (AnnName pairCon Nothing Nothing) rparen + prettySe p bnd (PDPair _ l t r) = + lparen <> prettySe 10 bnd l <+> text "**" <+> prettySe 10 bnd r <> rparen + prettySe p bnd (PAlternative a as) = lparen <> text "|" <> prettyAs <> text "|" <> rparen where prettyAs = - foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe 10) as - prettySe p PType = text "Type" - prettySe p (PConstant c) = pretty c + foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe 10 bnd) as + prettySe p bnd PType = annotate AnnConstType $ text "Type" + prettySe p bnd (PConstant c) = annotate (annot c) (text (show c)) + where annot (AType _) = AnnConstType + annot StrType = AnnConstType + annot PtrType = AnnConstType + annot VoidType = AnnConstType + annot _ = AnnConstData -- XXX: add pretty for tactics - prettySe p (PProof ts) = - text "proof" <+> lbrace $+$ nest nestingSize (text . show $ ts) $+$ rbrace - prettySe p (PTactics ts) = - text "tactics" <+> lbrace $+$ nest nestingSize (text . show $ ts) $+$ rbrace - prettySe p (PMetavar n) = text "?" <> pretty n - prettySe p (PReturn f) = text "return" - prettySe p PImpossible = text "impossible" - prettySe p Placeholder = text "_" - prettySe p (PDoBlock _) = text "do block pretty not implemented" - prettySe p (PElabError s) = pretty s + prettySe p bnd (PProof ts) = + text "proof" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace + prettySe p bnd (PTactics ts) = + text "tactics" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace + prettySe p bnd (PMetavar n) = text "?" <> pretty n + prettySe p bnd (PReturn f) = text "return" + prettySe p bnd PImpossible = text "impossible" + prettySe p bnd Placeholder = text "_" + prettySe p bnd (PDoBlock _) = text "do block pretty not implemented" + prettySe p bnd (PElabError s) = pretty s - prettySe p _ = text "test" + prettySe p bnd _ = text "test" - prettyArgS (PImp _ _ _ n tm _) = prettyArgSi (n, tm) - prettyArgS (PExp _ _ tm _) = prettyArgSe tm - prettyArgS (PConstraint _ _ tm _) = prettyArgSc tm - prettyArgS (PTacImplicit _ _ n _ tm _) = prettyArgSti (n, tm) + prettyArgS bnd (PImp _ _ _ n tm _) = prettyArgSi bnd (n, tm) + prettyArgS bnd (PExp _ _ tm _) = prettyArgSe bnd tm + prettyArgS bnd (PConstraint _ _ tm _) = prettyArgSc bnd tm + prettyArgS bnd (PTacImplicit _ _ n _ tm _) = prettyArgSti bnd (n, tm) - prettyArgSe arg = prettySe 0 arg - prettyArgSi (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe 10 val <> rbrace - prettyArgSc val = lbrace <> lbrace <> prettySe 10 val <> rbrace <> rbrace - prettyArgSti (n, val) = lbrace <> text "auto" <+> pretty n <+> text "=" <+> prettySe 10 val <> rbrace + prettyArgSe bnd arg = prettySe 0 bnd arg + prettyArgSi bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace + prettyArgSc bnd val = lbrace <> lbrace <> prettySe 10 bnd val <> rbrace <> rbrace + prettyArgSti bnd (n, val) = lbrace <> text "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace + basename :: Name -> Name + basename (NS n _) = basename n + basename n = n + + slist' p bnd (PApp _ (PRef _ nil) _) + | not impl && nsroot nil == sUN "Nil" = Just [] + slist' p bnd (PRef _ nil) + | not impl && nsroot nil == sUN "Nil" = Just [] + slist' p bnd (PApp _ (PRef _ cons) args) + | nsroot cons == sUN "::", + (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args, + all isImp imps, + Just tl' <- slist' p bnd tl + = Just (hd:tl') + where + isImp (PImp {}) = True + isImp _ = False + slist' _ _ tm = Nothing + + slist p bnd e | Just es <- slist' p bnd e = Just $ + case es of [] -> annotate AnnConstData $ text "[]" + [x] -> enclose left right . group $ + prettySe p bnd x + xs -> (enclose left right . + align . group . vsep . + punctuate comma . + map (prettySe p bnd)) xs + where left = (annotate AnnConstData (text "[")) + right = (annotate AnnConstData (text "]")) + comma = (annotate AnnConstData (text ",")) + slist _ _ _ = Nothing + + natns = "Prelude.Nat." + + snat p (PRef _ z) + | show z == (natns++"Z") || show z == "Z" = 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 + bracket outer inner doc | inner > outer = lparen <> doc <> rparen | otherwise = doc +-- | Pretty-printer helper for the binding site of a name +bindingOf :: Name -- ^^ the bound name + -> Bool -- ^^ whether the name is implicit + -> Doc OutputAnnotation +bindingOf n imp = annotate (AnnBoundName n imp) (text (show n)) + +-- | Pretty-printer helper for names that attaches the correct annotations +prettyName :: Bool -- ^^ whether to show namespaces + -> [(Name, Bool)] -- ^^ the current bound variables and whether they are implicit + -> Name -- ^^ the name to pprint + -> Doc OutputAnnotation +prettyName showNS bnd n | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) (text (strName n)) + | otherwise = annotate (AnnName n Nothing Nothing) (text (strName n)) + where strName (UN n) = T.unpack n + strName (NS n ns) | showNS = (concatMap (++ ".") . map T.unpack . reverse) ns ++ strName n + | otherwise = strName n + strName (MN i s) = T.unpack s + strName other = show other + + +showCImp :: Bool -> PClause -> Doc OutputAnnotation +showCImp impl (PClause _ n l ws r w) + = prettyImp impl l <+> showWs ws <+> text "=" <+> prettyImp impl r + <+> text "where" <+> text (show w) + where + showWs [] = empty + showWs (x : xs) = text "|" <+> prettyImp impl x <+> showWs xs +showCImp impl (PWith _ n l ws r w) + = prettyImp impl l <+> showWs ws <+> text "with" <+> prettyImp impl r + <+> braces (text (show w)) + where + showWs [] = empty + showWs (x : xs) = text "|" <+> prettyImp impl x <+> showWs xs + + +showDImp :: Bool -> PData -> Doc OutputAnnotation +showDImp impl (PDatadecl n ty cons) + = text "data" <+> text (show n) <+> colon <+> prettyImp impl ty <+> text "where" <$> + (indent 2 $ vsep (map (\ (_, n, t, _, _) -> pipe <+> prettyName False [] n <+> colon <+> prettyImp impl t) cons)) + +showDecls :: Bool -> [PDecl] -> Doc OutputAnnotation +showDecls i ds = vsep (map (showDeclImp i) ds) + +showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops)) +showDeclImp i (PTy _ _ _ _ n t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp i t +showDeclImp i (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+> + indent 2 (vsep (map (showCImp i) cs)) +showDeclImp _ (PData _ _ _ _ d) = showDImp True d +showDeclImp i (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls i ps <> line) +showDeclImp i (PNamespace n ps) = text "namespace" <+> text n <> braces (line <> showDecls i ps <> line) +showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn) +showDeclImp i (PClass _ _ _ cs n ps ds) + = text "class" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls i ds +showDeclImp i (PInstance _ _ cs n _ t _ ds) + = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp i t <> line <> showDecls i ds +showDeclImp _ _ = text "..." +-- showDeclImp (PImport i) = "import " ++ i + +instance Show (Doc OutputAnnotation) where + show = flip (displayS . renderCompact) "" + +getImps :: [PArg] -> [(Name, PTerm)] +getImps [] = [] +getImps (PImp _ _ _ n tm _ : xs) = (n, tm) : getImps xs +getImps (_ : xs) = getImps xs + +getExps :: [PArg] -> [PTerm] +getExps [] = [] +getExps (PExp _ _ tm _ : xs) = tm : getExps xs +getExps (_ : xs) = getExps xs + +getConsts :: [PArg] -> [PTerm] +getConsts [] = [] +getConsts (PConstraint _ _ tm _ : xs) = tm : getConsts xs +getConsts (_ : xs) = getConsts xs + +getAll :: [PArg] -> [PTerm] +getAll = map getTm + + -- | Show Idris name showName :: Maybe IState -- ^^ the Idris state, for information about names and colours -> [(Name, Bool)] -- ^^ the bound variables and whether they're implicit @@ -1143,8 +1359,8 @@ Nothing -> showbasic n where name = if impl then show n else showbasic n showbasic n@(UN _) = showCG n - showbasic (MN _ s) = s - showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n + showbasic (MN _ s) = str s + showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n showbasic (SN s) = show s fst3 (x, _, _) = x colourise n t = let ctxt' = fmap tt_ctxt ist in @@ -1160,166 +1376,14 @@ -- (like error messages). Thus, unknown vars are colourised as implicits. | otherwise -> colouriseImplicit t name --- | Show Idris term -showImp :: Maybe IState -- ^^ the Idris state, for information about identifiers and colours - -> Bool -- ^^ whether to show implicits - -> Bool -- ^^ whether to colourise - -> PTerm -- ^^ the term to show - -> String -showImp ist impl colour tm = se 10 [] tm where - perhapsColourise :: (ColourTheme -> String -> String) -> String -> String - perhapsColourise col str = case ist of - Just i -> if colour then col (idris_colourTheme i) str else str - Nothing -> str - - se :: Int -> [(Name, Bool)] -> PTerm -> String - se p bnd (PQuote r) = "![" ++ show r ++ "]" - se p bnd (PPatvar fc n) = if impl then show n ++ "[p]" else show n - se p bnd (PInferRef fc n) = "!" ++ show n -- ++ "[" ++ show fc ++ "]" - se p bnd e - | Just str <- slist p bnd e = str - | Just num <- snat p e = perhapsColourise colouriseData (show num) - se p bnd (PRef fc n) = showName ist bnd impl colour n - se p bnd (PLam n ty sc) = bracket p 2 $ "\\ " ++ perhapsColourise colouriseBound (show n) ++ - (if impl then " : " ++ se 10 bnd ty else "") ++ " => " - ++ se 10 ((n, False):bnd) sc - se p bnd (PLet n ty v sc) = bracket p 2 $ "let " ++ perhapsColourise colouriseBound (show n) ++ - " = " ++ se 10 bnd v ++ - " in " ++ se 10 ((n, False):bnd) sc - se p bnd (PPi (Exp l s _ param) n ty sc) - | n `elem` allNamesIn sc || impl - = bracket p 2 $ - (if l then "|(" else "(") ++ - perhapsColourise colouriseBound (show n) ++ " : " ++ se 10 bnd ty ++ - ") " ++ - (if (impl && param) then "P" else "") ++ - st ++ - "-> " ++ se 10 ((n, False):bnd) sc - | otherwise = bracket p 2 $ se 0 bnd ty ++ " " ++ st ++ "-> " ++ se 10 bnd sc - where st = case s of - Static -> "[static] " - _ -> "" - se p bnd (PPi (Imp l s _ _) n ty sc) - | impl = bracket p 2 $ (if l then "|{" else "{") ++ - perhapsColourise colouriseBound (show n) ++ " : " ++ se 10 bnd ty ++ - "} " ++ st ++ "-> " ++ se 10 ((n, True):bnd) sc - | otherwise = se 10 ((n, True):bnd) sc - where st = case s of - Static -> "[static] " - _ -> "" - se p bnd (PPi (Constraint _ _ _) n ty sc) - = bracket p 2 $ se 10 bnd ty ++ " => " ++ se 10 bnd sc - se p bnd (PPi (TacImp _ _ s _) n ty sc) - = bracket p 2 $ - "{tacimp " ++ (perhapsColourise colouriseBound (show n)) ++ " : " ++ se 10 bnd ty ++ "} -> " ++ - se 10 ((n, False):bnd) sc - se p bnd (PMatchApp _ f) = "match " ++ show f - se p bnd (PApp _ hd@(PRef _ f) []) - | not impl = se p bnd hd - se p bnd (PAppBind _ hd@(PRef _ f) []) - | not impl = "!" ++ se p bnd hd - se p bnd (PApp _ op@(PRef _ (UN (f:_))) args) - | length (getExps args) == 2 && not impl && not (isAlpha f) - = let [l, r] = getExps args in - bracket p 1 $ se 1 bnd l ++ " " ++ se p bnd op ++ " " ++ se 0 bnd r - se p bnd (PApp _ f as) - = -- let args = getExps as in - bracket p 1 $ se 1 bnd f ++ - if impl then concatMap (sArg bnd) as - else concatMap (suiArg impl bnd) as - se p bnd (PAppBind _ f as) - = let args = getExps as in - "!" ++ (bracket p 1 $ se 1 bnd f ++ if impl then concatMap (sArg bnd) as - else concatMap (seArg bnd) args) - se p bnd (PCase _ scr opts) = "case " ++ se 10 bnd scr ++ " of " ++ showSep " | " (map sc opts) - where sc (l, r) = se 10 bnd l ++ " => " ++ se 10 bnd r - se p bnd (PHidden tm) = "." ++ se 0 bnd tm - se p bnd (PRefl _ t) - | not impl = perhapsColourise colouriseData "refl" - | otherwise = perhapsColourise colouriseData $ "refl {" ++ se 10 bnd t ++ "}" - se p bnd (PResolveTC _) = "resolvetc" - se p bnd (PTrue _) = perhapsColourise colouriseType "()" - se p bnd (PFalse _) = perhapsColourise colouriseType "_|_" - se p bnd (PEq _ l r) = bracket p 2 $ se 10 bnd l ++ perhapsColourise colouriseType " = " ++ se 10 bnd r - se p bnd (PRewrite _ l r _) = bracket p 2 $ "rewrite " ++ se 10 bnd l ++ " in " ++ se 10 bnd r - se p bnd (PTyped l r) = "(" ++ se 10 bnd l ++ " : " ++ se 10 bnd r ++ ")" - se p bnd (PPair _ l r) = "(" ++ se 10 bnd l ++ ", " ++ se 10 bnd r ++ ")" - se p bnd (PDPair _ l t r) = "(" ++ se 10 bnd l ++ " ** " ++ se 10 bnd r ++ ")" - se p bnd (PAlternative a as) = "(|" ++ showSep " , " (map (se 10 bnd) as) ++ "|)" - se p bnd PType = perhapsColourise colouriseType "Type" - se p bnd (PConstant c) = perhapsColourise (cfun c) (show c) - where cfun (AType _) = colouriseType - cfun StrType = colouriseType - cfun PtrType = colouriseType - cfun VoidType = colouriseType - cfun _ = colouriseData - se p bnd (PProof ts) = "proof { " ++ show ts ++ "}" - se p bnd (PTactics ts) = "tactics { " ++ show ts ++ "}" - se p bnd (PMetavar n) = "?" ++ show n - se p bnd (PReturn f) = "return" - se p bnd PImpossible = "impossible" - se p bnd Placeholder = "_" - se p bnd (PDoBlock _) = "do block show not implemented" - se p bnd (PElabError s) = show s - se p bnd (PCoerced t) = se p bnd t - se p bnd (PUnifyLog t) = "%unifyLog " ++ se p bnd t - se p bnd (PNoImplicits t) = "%noimplicit " ++ se p bnd t --- se p bnd x = "Not implemented" - - slist' p bnd (PApp _ (PRef _ nil) _) - | not impl && nsroot nil == UN "Nil" = Just [] - slist' p bnd (PApp _ (PRef _ cons) args) - | nsroot cons == UN "::", - (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args, - all isImp imps, - Just tl' <- slist' p bnd tl - = Just (hd:tl') - where - isImp (PImp {}) = True - isImp _ = False - slist' _ _ _ = Nothing - - slist p bnd e | Just es <- slist' p bnd e = Just $ - case es of [] -> "[]" - [x] -> "[" ++ se p bnd x ++ "]" - xs -> "[" ++ intercalate "," (map (se p bnd ) xs) ++ "]" - slist _ _ _ = Nothing - - -- since Prelude is always imported, S & Z are unqualified iff they're the - -- Nat ones. - snat p (PRef _ o) - | show o == (natns++"Z") || show o == "Z" = 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 bnd (PImp _ _ _ n tm _) = siArg bnd (n, tm) - sArg bnd (PExp _ _ tm _) = seArg bnd tm - sArg bnd (PConstraint _ _ tm _) = scArg bnd tm - sArg bnd (PTacImplicit _ _ n _ tm _) = stiArg bnd (n, tm) - - -- show argument, implicits given by the user also shown - suiArg impl bnd (PImp _ mi _ n tm _) - | impl || not mi = siArg bnd (n, tm) - suiArg impl bnd (PExp _ _ tm _) = seArg bnd tm - suiArg impl bnd _ = "" - - seArg bnd arg = " " ++ se 0 bnd arg - siArg bnd (n, val) = - let n' = show n - val' = se 10 bnd val in - if (n' == val') - then " {" ++ n' ++ "}" - else " {" ++ n' ++ " = " ++ val' ++ "}" - scArg bnd val = " {{" ++ se 10 bnd val ++ "}}" - stiArg bnd (n, val) = " {auto " ++ show n ++ " = " ++ se 10 bnd val ++ "}" +showTm :: IState -- ^^ the Idris state, for information about identifiers and colours + -> PTerm -- ^^ the term to show + -> String +showTm ist = displayDecorated (consoleDecorate ist) . renderCompact . prettyImp (opt_showimp (idris_options ist)) - bracket outer inner str | inner > outer = "(" ++ str ++ ")" - | otherwise = str +-- | Show a term with implicits, no colours +showTmImpls :: PTerm -> String +showTmImpls = flip (displayS . renderCompact . prettyImp True) "" instance Sized PTerm where @@ -1332,17 +1396,18 @@ size (PApp fc name args) = 1 + size args size (PAppBind fc name args) = 1 + size args size (PCase fc trm bdy) = 1 + size trm + size bdy - size (PTrue fc) = 1 + size (PTrue fc _) = 1 size (PFalse fc) = 1 size (PRefl fc _) = 1 size (PResolveTC fc) = 1 size (PEq fc left right) = 1 + size left + size right size (PRewrite fc left right _) = 1 + size left + size right - size (PPair 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 size (PHidden hidden) = size hidden size (PUnifyLog tm) = size tm + size (PDisamb _ tm) = size tm size (PNoImplicits tm) = size tm size PType = 1 size (PConstant const) = 1 + size const @@ -1366,6 +1431,7 @@ where ni env (PRef _ n) | not (n `elem` env) = [n] + ni env (PPatvar _ n) = [n] ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os) @@ -1375,16 +1441,39 @@ 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 (PPair _ _ l r) = ni env l ++ ni env r ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r ni env (PAlternative a ls) = concatMap (ni env) ls ni env (PUnifyLog tm) = ni env tm + ni env (PDisamb _ tm) = ni env tm ni env (PNoImplicits tm) = ni env tm ni env _ = [] --- Return names which are free in the given term. +-- Return all names defined in binders in the given term +boundNamesIn :: PTerm -> [Name] +boundNamesIn tm = nub $ ni tm + where + ni (PApp _ f as) = ni f ++ concatMap (ni) (map getTm as) + ni (PAppBind _ f as) = ni f ++ concatMap (ni) (map getTm as) + ni (PCase _ c os) = ni c ++ concatMap (ni) (map snd os) + ni (PLam n ty sc) = n : (ni ty ++ ni sc) + ni (PLet n ty val sc) = n : (ni ty ++ ni val ++ ni sc) + ni (PPi _ n ty sc) = n : (ni ty ++ ni sc) + ni (PEq _ l r) = ni l ++ ni r + ni (PRewrite _ l r _) = ni l ++ ni r + ni (PTyped l r) = ni l ++ ni r + ni (PPair _ _ l r) = ni l ++ ni r + ni (PDPair _ (PRef _ n) t r) = ni t ++ ni r + ni (PDPair _ l t r) = ni l ++ ni t ++ ni r + ni (PAlternative a as) = concatMap (ni) as + ni (PHidden tm) = ni tm + ni (PUnifyLog tm) = ni tm + ni (PDisamb _ tm) = ni tm + ni (PNoImplicits tm) = ni tm + ni _ = [] +-- Return names which are free in the given term. namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name] namesIn uvars ist tm = nub $ ni [] tm where @@ -1401,12 +1490,13 @@ 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 (PPair _ _ l r) = ni env l ++ ni env r ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r ni env (PAlternative a as) = concatMap (ni env) as ni env (PHidden tm) = ni env tm ni env (PUnifyLog tm) = ni env tm + ni env (PDisamb _ tm) = ni env tm ni env (PNoImplicits tm) = ni env tm ni env _ = [] @@ -1428,12 +1518,13 @@ 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 (PPair _ _ l r) = ni env l ++ ni env r ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r ni env (PAlternative a as) = concatMap (ni env) as ni env (PHidden tm) = ni env tm ni env (PUnifyLog tm) = ni env tm + ni env (PDisamb _ tm) = ni env tm ni env (PNoImplicits tm) = ni env tm ni env _ = [] diff --git a/src/Idris/CaseSplit.hs b/src/Idris/CaseSplit.hs --- a/src/Idris/CaseSplit.hs +++ b/src/Idris/CaseSplit.hs @@ -15,9 +15,9 @@ import Idris.Parser import Idris.Error -import Core.TT -import Core.Typecheck -import Core.Evaluate +import Idris.Core.TT +import Idris.Core.Typecheck +import Idris.Core.Evaluate import Data.Maybe import Data.Char @@ -62,11 +62,11 @@ Just ty -> do let splits = findPats ist ty iLOG ("New patterns " ++ showSep ", " - (map (showImp Nothing True False) splits)) + (map showTmImpls splits)) let newPats_in = zipWith (replaceVar ctxt n) splits (repeat t) logLvl 4 ("Working from " ++ show t) logLvl 4 ("Trying " ++ showSep "\n" - (map (showImp Nothing True False) newPats_in)) + (map (showTmImpls) newPats_in)) newPats <- mapM elabNewPat newPats_in logLvl 3 ("Original:\n" ++ show t) logLvl 3 ("Split:\n" ++ @@ -91,7 +91,8 @@ Nothing -> [] Just t -> getNameHints ist t let nsupp = case n of - MN i ('_':_) -> mkSupply (supp ++ varlist) + MN i n | not (tnull n) && thead n == '_' + -> mkSupply (supp ++ varlist) MN i n -> mkSupply (UN n : supp ++ varlist) x -> mkSupply (x : supp) let badnames = map snd (namemap ms) ++ map snd (invented ms) ++ @@ -106,7 +107,7 @@ mkSupply ns = mkSupply' ns (map nextName ns) where mkSupply' xs ns' = xs ++ mkSupply ns' -varlist = map (UN . (:[])) "xyzwstuv" -- EB's personal preference :) +varlist = map (sUN . (:[])) "xyzwstuv" -- EB's personal preference :) stripNS tm = mapPT dens tm where dens (PRef fc n) = PRef fc (nsroot n) @@ -164,7 +165,7 @@ = case lookupTy n (tt_ctxt ist) of [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing _ -> repeat Nothing - where tyName (Bind _ (Pi _) _) = Just (UN "->") + where tyName (Bind _ (Pi _) _) = Just (sUN "->") tyName t | (P _ n _, _) <- unApply t = Just n | otherwise = Nothing argTys _ _ = repeat Nothing @@ -221,7 +222,7 @@ subst (PApp fc (PRef _ t) pats) | isTConName t ctxt = Placeholder -- infer types subst (PApp fc f pats) = PApp fc f (map substArg pats) - subst (PEq fc l r) = PEq fc (subst l) (subst r) + subst (PEq fc l r) = Placeholder -- PEq fc (subst l) (subst r) subst x = x substArg arg = arg { getTm = subst (getTm arg) } @@ -236,7 +237,7 @@ -- let (before, later) = splitAt (l-1) (lines inp) -- i <- getIState cl <- getInternalApp fn l - logLvl 3 ("Working with " ++ showImp Nothing True False cl) + logLvl 3 ("Working with " ++ showTmImpls cl) tms <- split n cl -- iputStrLn (showSep "\n" (map show tms)) return tms -- "" -- not yet done... @@ -245,7 +246,7 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups) where rep str [] = str ++ "\n" - rep str ((n, tm) : ups) = rep (updatePat False (show n) (nshow False tm) str) ups + rep str ((n, tm) : ups) = rep (updatePat False (show n) (nshow tm) str) ups updateRHSs i [] = return [] updateRHSs i (x : xs) = do (x', i') <- updateRHS i x @@ -264,11 +265,10 @@ -- TMP HACK: If there are Nats, we don't want to show as numerals since -- this isn't supported in a pattern, so special case here - nshow brack (PRef _ (UN "Z")) = "Z" - nshow brack (PApp _ (PRef _ (UN "S")) [x]) = - if brack then "(S " else "S " ++ nshow True (getTm x) ++ - if brack then ")" else "" - nshow _ t = show t + nshow (PRef _ (UN z)) | z == txt "Z" = "Z" + nshow (PApp _ (PRef _ (UN s)) [x]) | s == txt "S" = + "S " ++ addBrackets (nshow (getTm x)) + nshow t = show t -- if there's any {n} replace with {n=n} expandBraces ('{' : xs) @@ -297,7 +297,7 @@ getUniq nm i = do ist <- getIState let n = nameRoot [] nm ++ "_" ++ show i - case lookupTy (UN n) (tt_ctxt ist) of + case lookupTy (sUN n) (tt_ctxt ist) of [] -> return (n, i+1) _ -> getUniq nm (i+1) @@ -325,13 +325,14 @@ mkApp i _ _ = "" getNameFrom i used (PPi _ _ _ _) - = uniqueNameFrom (mkSupply [UN "f", UN "g"]) used + = uniqueNameFrom (mkSupply [sUN "f", sUN "g"]) used getNameFrom i used (PApp fc f as) = getNameFrom i used f + getNameFrom i used (PEq _ _ _) = uniqueNameFrom [sUN "prf"] used getNameFrom i used (PRef fc f) = case getNameHints i f of - [] -> uniqueName (UN "x") used + [] -> uniqueName (sUN "x") used ns -> uniqueNameFrom (mkSupply ns) used - getNameFrom i used _ = uniqueName (UN "x") used + getNameFrom i used _ = uniqueName (sUN "x") used getProofClause :: Int -- ^ line number that the type is declared -> Name -- ^ Function name @@ -363,11 +364,11 @@ nameMissing :: [PTerm] -> Idris [PTerm] nameMissing ps = do ist <- get newPats <- mapM nm ps - let newPats' = mergeAllPats ist (UN "_") (base (head ps)) + let newPats' = mergeAllPats ist (sUN "_") (base (head ps)) newPats return (map fst newPats') where - base (PApp fc f args) = PApp fc f (map (fmap (const (PRef fc (UN "_")))) args) + base (PApp fc f args) = PApp fc f (map (fmap (const (PRef fc (sUN "_")))) args) base t = t nm ptm = do mptm <- elabNewPat ptm diff --git a/src/Idris/Chaser.hs b/src/Idris/Chaser.hs --- a/src/Idris/Chaser.hs +++ b/src/Idris/Chaser.hs @@ -70,9 +70,11 @@ buildTree :: [FilePath] -> -- already guaranteed built FilePath -> Idris [ModuleTree] -buildTree built fp = idrisCatch (btree [] fp) - (\e -> do now <- runIO $ getCurrentTime - return [MTree (IDR fp) True now []]) +buildTree built fp = btree [] fp +-- = idrisCatch (btree [] fp) +-- (\e -> do now <- runIO $ getCurrentTime +-- iputStrLn (show e) +-- return [MTree (IDR fp) True now []]) where btree done f = do i <- getIState @@ -81,6 +83,7 @@ ibcsd <- valIBCSubDir i ids <- allImportDirs fp <- runIO $ findImport ids ibcsd file + iLOG $ "Found " ++ show fp mt <- runIO $ getIModTime fp if (file `elem` built) then return [MTree fp False mt []] @@ -123,13 +126,13 @@ else return False children :: Bool -> FilePath -> [FilePath] -> Idris [ModuleTree] - children lit f done = idrisCatch - (do exist <- runIO $ doesFileExist f + children lit f done = -- idrisCatch + do exist <- runIO $ doesFileExist f if exist then do file_in <- runIO $ readFile f file <- if lit then tclift $ unlit f file_in else return file_in (_, modules, _) <- parseImports f file - ms <- mapM (btree done) modules + ms <- mapM (btree done) [realName | (realName, alias, fc) <- modules] return (concat ms) - else return []) -- IBC with no source available - (\c -> return []) -- error, can't chase modules here + else return [] -- IBC with no source available +-- (\c -> return []) -- error, can't chase modules here diff --git a/src/Idris/Completion.hs b/src/Idris/Completion.hs --- a/src/Idris/Completion.hs +++ b/src/Idris/Completion.hs @@ -1,8 +1,8 @@ -- | Support for command-line completion at the REPL and in the prover module Idris.Completion (replCompletion, proverCompletion) where -import Core.Evaluate (ctxtAlist) -import Core.TT +import Idris.Core.Evaluate (ctxtAlist) +import Idris.Core.TT import Idris.AbsSyntaxTree import Idris.Help @@ -40,9 +40,11 @@ , ("exact", Just ExprTArg) , ("equiv", Just ExprTArg) , ("applyTactic", Just ExprTArg) + , ("byReflection", Just ExprTArg) , ("reflect", Just ExprTArg) , ("fill", Just ExprTArg) , ("try", Just AltsTArg) + , ("induction", Just NameTArg) ] ++ map (\x -> (x, Nothing)) [ "intros", "compute", "trivial", "solve", "attack", "state", "term", "undo", "qed", "abandon", ":q" @@ -52,9 +54,9 @@ -- | Convert a name into a string usable for completion. Filters out names -- that users probably don't want to see. nameString :: Name -> Maybe String -nameString (UN ('@':_)) = Nothing -nameString (UN ('#':_)) = Nothing -nameString (UN n) = Just n +nameString (UN nm) + | not (tnull nm) && (thead nm == '@' || thead nm == '#') = Nothing +nameString (UN n) = Just (str n) nameString (NS n _) = nameString n nameString _ = Nothing @@ -102,8 +104,12 @@ completeOption :: CompletionFunc Idris completeOption = completeWord Nothing " \t" completeOpt - where completeOpt = return . (completeWith ["errorcontext", "showimplicits"]) + where completeOpt = return . completeWith ["errorcontext", "showimplicits", "originalerrors"] +completeConsoleWidth :: CompletionFunc Idris +completeConsoleWidth = completeWord Nothing " \t" completeW + where completeW = return . completeWith ["auto", "infinite", "80", "120"] + isWhitespace :: Char -> Bool isWhitespace = (flip elem) " \t\n" @@ -150,6 +156,7 @@ completeArg MetaVarArg = completeMetaVar (prev, next) -- FIXME only complete one name completeArg ColourArg = completeColour (prev, next) completeArg NoArg = noCompletion (prev, next) + completeArg ConsoleWidthArg = completeConsoleWidth (prev, next) completeCmdName = return $ ("", completeWith commands cmd) -- | Complete REPL commands and defined identifiers diff --git a/src/Idris/Core/CaseTree.hs b/src/Idris/Core/CaseTree.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Core/CaseTree.hs @@ -0,0 +1,639 @@ +{-# LANGUAGE PatternGuards, DeriveFunctor, TypeSynonymInstances #-} + +module Idris.Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..), + Phase(..), CaseTree, + simpleCase, small, namesUsed, findCalls, findUsedArgs) where + +import Idris.Core.TT + +import Control.Monad.State +import Data.Maybe +import Data.List hiding (partition) +import Debug.Trace + +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 + | STerm !t + | UnmatchedCase String -- ^ error message + | ImpossibleCase -- ^ already checked to be impossible + deriving (Eq, Ord, Functor) +{-! +deriving instance Binary SC' +deriving instance NFData SC' +!-} + +type SC = SC' Term + +data CaseAlt' t = ConCase Name Int [Name] !(SC' t) + | FnCase Name [Name] !(SC' t) -- ^ reflection function + | ConstCase Const !(SC' t) + | SucCase Name !(SC' t) + | DefaultCase !(SC' t) + deriving (Show, Eq, Ord, Functor) +{-! +deriving instance Binary CaseAlt' +deriving instance NFData CaseAlt' +!-} + +type CaseAlt = CaseAlt' Term + +instance Show t => Show (SC' t) where + show sc = show' 1 sc + where + show' i (Case n alts) = "case " ++ show n ++ " of\n" ++ indent i ++ + showSep ("\n" ++ indent i) (map (showA i) alts) + show' i (ProjCase tm alts) = "case " ++ show tm ++ " of " ++ + showSep ("\n" ++ indent i) (map (showA i) alts) + show' i (STerm tm) = show tm + show' i (UnmatchedCase str) = "error " ++ show str + show' i ImpossibleCase = "impossible" + + indent i = concat $ take i (repeat " ") + + showA i (ConCase n t args sc) + = show n ++ "(" ++ showSep (", ") (map show args) ++ ") => " + ++ show' (i+1) sc + showA i (FnCase n args sc) + = "FN " ++ show n ++ "(" ++ showSep (", ") (map show args) ++ ") => " + ++ show' (i+1) sc + showA i (ConstCase t sc) + = show t ++ " => " ++ show' (i+1) sc + showA i (SucCase n sc) + = show n ++ "+1 => " ++ show' (i+1) sc + showA i (DefaultCase sc) + = "_ => " ++ show' (i+1) sc + + +type CaseTree = SC +type Clause = ([Pat], (Term, Term)) +type CS = ([Term], Int, [(Name, Type)]) + +instance TermSize SC where + termsize n (Case n' as) = termsize n as + termsize n (ProjCase n' as) = termsize n as + termsize n (STerm t) = termsize n t + termsize n _ = 1 + +instance TermSize CaseAlt where + termsize n (ConCase _ _ _ s) = termsize n s + termsize n (FnCase _ _ s) = termsize n s + termsize n (ConstCase _ s) = termsize n s + termsize n (SucCase _ s) = termsize n s + termsize n (DefaultCase s) = termsize n s + +-- simple terms can be inlined trivially - good for primitives in particular +-- To avoid duplicating work, don't inline something which uses one +-- of its arguments in more than one place + +small :: Name -> [Name] -> SC -> Bool +small n args t = let as = findAllUsedArgs t args in + length as == length (nub as) && + termsize n t < 10 + +namesUsed :: SC -> [Name] +namesUsed sc = nub $ nu' [] sc where + nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n] + nu' ps (ProjCase t alts) = nub $ (nut ps t ++ + (concatMap (nua ps) alts)) + nu' ps (STerm t) = nub $ nut ps t + nu' ps _ = [] + + nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc) \\ args + nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc) \\ args + nua ps (ConstCase _ sc) = nu' ps sc + nua ps (SucCase _ sc) = nu' ps sc + nua ps (DefaultCase sc) = nu' ps sc + + nut ps (P _ n _) | n `elem` ps = [] + | otherwise = [n] + nut ps (App f a) = nut ps f ++ nut ps a + nut ps (Proj t _) = nut ps t + nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc + nut ps (Bind n b sc) = nut (n:ps) sc + nut ps _ = [] + +-- Return all called functions, and which arguments are used in each argument position +-- for the call, in order to help reduce compilation time, and trace all unused +-- arguments + +findCalls :: SC -> [Name] -> [(Name, [[Name]])] +findCalls sc topargs = nub $ nu' topargs sc where + nu' ps (Case n alts) = nub (concatMap (nua (n : ps)) alts) + nu' ps (ProjCase t alts) = nub (nut ps t ++ concatMap (nua ps) alts) + nu' ps (STerm t) = nub $ nut ps t + nu' ps _ = [] + + nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc) + nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc) + nua ps (ConstCase _ sc) = nu' ps sc + nua ps (SucCase _ sc) = nu' ps sc + nua ps (DefaultCase sc) = nu' ps sc + + nut ps (P Ref n _) | n `elem` ps = [] + | otherwise = [(n, [])] -- tmp + nut ps fn@(App f a) + | (P Ref n _, args) <- unApply fn + = if n `elem` ps then nut ps f ++ nut ps a + else [(n, map argNames args)] ++ concatMap (nut ps) args + | (P (TCon _ _) n _, _) <- unApply fn = [] + | otherwise = nut ps f ++ nut ps a + nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc + nut ps (Proj t _) = nut ps t + nut ps (Bind n b sc) = nut (n:ps) sc + nut ps _ = [] + + argNames tm = let ns = directUse tm in + filter (\x -> x `elem` ns) topargs + +-- Find names which are used directly (i.e. not in a function call) in a term + +directUse :: Eq n => TT n -> [n] +directUse (P _ n _) = [n] +directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n]) + ++ directUse t +directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n]) +directUse fn@(App f a) + | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them + | (P (TCon _ _) n _, args) <- unApply fn = [] -- type constructors not used at runtime + | otherwise = nub $ directUse f ++ directUse a +directUse (Proj x i) = nub $ directUse x +directUse _ = [] + +-- Find all directly used arguments (i.e. used but not in function calls) + +findUsedArgs :: SC -> [Name] -> [Name] +findUsedArgs sc topargs = nub (findAllUsedArgs sc topargs) + +findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where + nu' (Case n alts) = n : concatMap nua alts + nu' (ProjCase t alts) = directUse t ++ concatMap nua alts + nu' (STerm t) = directUse t + nu' _ = [] + + nua (ConCase n i args sc) = nu' sc + nua (FnCase n args sc) = nu' sc + nua (ConstCase _ sc) = nu' sc + nua (SucCase _ sc) = nu' sc + nua (DefaultCase sc) = nu' sc + +data Phase = CompileTime | RunTime + deriving (Show, Eq) + +-- Generate a simple case tree +-- Work Right to Left + +simpleCase :: Bool -> Bool -> Bool -> + Phase -> FC -> [Type] -> + [([Name], Term, Term)] -> + TC CaseDef +simpleCase tc cover reflect phase fc argtys 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") [] + sc' tc cover phase fc cs + = let proj = phase == RunTime + vnames = fstT (head cs) + pats = map (\ (avs, l, r) -> + (avs, toPats reflect tc l, (l, r))) cs + chkPats = mapM chkAccessible pats in + case chkPats of + OK pats -> + let numargs = length (fst (head pats)) + ns = take numargs args + (ns', ps') = order ns pats + (tree, st) = runState + (match ns' ps' (defaultCase cover)) + ([], numargs, []) + t = CaseDef ns (prune proj (depatt ns' tree)) (fstT st) in + if proj then return (stripLambdas t) + else return t +-- FIXME: This check is not quite right in some cases, and is breaking +-- perfectly valid code! +-- if checkSameTypes (lstT st) tree +-- then return t +-- else Error (At fc (Msg "Typecase is not allowed")) + Error err -> Error (At fc err) + where args = map (\i -> sMN i "e") [0..] + defaultCase True = STerm Erased + defaultCase False = UnmatchedCase "Error" + fstT (x, _, _) = x + lstT (_, _, x) = x + + chkAccessible (avs, l, c) + | phase == RunTime || reflect = return (l, c) + | otherwise = do mapM_ (acc l) avs + return (l, c) + + acc [] n = Error (Inaccessible n) + acc (PV x t : xs) n | x == n = OK () + acc (PCon _ _ ps : xs) n = acc (ps ++ xs) n + acc (PSuc p : xs) n = acc (p : xs) n + acc (_ : xs) n = acc xs n + +-- For each 'Case', make sure every choice is in the same type family, +-- as directed by the variable type (i.e. there is no implicit type casing +-- going on). + +checkSameTypes :: [(Name, Type)] -> SC -> Bool +checkSameTypes tys (Case n alts) + = case lookup n tys of + Just t -> and (map (checkAlts t) alts) + _ -> and (map ((checkSameTypes tys).getSC) alts) + where + checkAlts t (ConCase n _ _ sc) = isType n t && checkSameTypes tys sc + checkAlts (Constant t) (ConstCase c sc) = isConstType c t && checkSameTypes tys sc + checkAlts _ (ConstCase c sc) = False + checkAlts _ _ = True + + getSC (ConCase _ _ _ sc) = sc + getSC (FnCase _ _ sc) = sc + getSC (ConstCase _ sc) = sc + getSC (SucCase _ sc) = sc + getSC (DefaultCase sc) = sc +checkSameTypes _ _ = True + +-- FIXME: All we're actually doing here is checking that we haven't arrived +-- at a specific constructor for a polymorphic argument. I *think* this +-- is sufficient, but if it turns out not to be, fix it! +isType n t | (P (TCon _ _) _ _, _) <- unApply t = True +isType n t | (P Ref _ _, _) <- unApply t = True +isType n t = False + +isConstType (I _) (AType (ATInt ITNative)) = True +isConstType (BI _) (AType (ATInt ITBig)) = True +isConstType (Fl _) (AType ATFloat) = True +isConstType (Ch _) (AType (ATInt ITChar)) = True +isConstType (Str _) StrType = True +isConstType (B8 _) (AType (ATInt _)) = True +isConstType (B16 _) (AType (ATInt _)) = True +isConstType (B32 _) (AType (ATInt _)) = True +isConstType (B64 _) (AType (ATInt _)) = True +isConstType (B8V _) (AType (ATInt _)) = True +isConstType (B16V _) (AType (ATInt _)) = True +isConstType (B32V _) (AType (ATInt _)) = True +isConstType (B64V _) (AType (ATInt _)) = True +isConstType _ _ = False + +data Pat = PCon Name Int [Pat] + | PConst Const + | PV Name Type + | PSuc Pat -- special case for n+1 on Integer + | PReflected Name [Pat] + | PAny + | PTyPat -- typecase, not allowed, inspect last + deriving Show + +-- If there are repeated variables, take the *last* one (could be name shadowing +-- in a where clause, so take the most recent). + +toPats :: Bool -> Bool -> Term -> [Pat] +toPats reflect tc f = reverse (toPat reflect tc (getArgs f)) where + getArgs (App f a) = a : getArgs f + getArgs _ = [] + +toPat :: Bool -> Bool -> [Term] -> [Pat] +toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) [] + where + toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args + return $ PCon n t args' + -- n + 1 + toPat' (P _ (UN pabi) _) + [p, Constant (BI 1)] | pabi == txt "prim__addBigInt" + = do p' <- toPat' p [] + return $ PSuc p' + -- Typecase +-- toPat' (P (TCon t a) n _) args | tc +-- = do args' <- mapM (\x -> toPat' x []) args +-- return $ PCon n t args' +-- toPat' (Constant (AType (ATInt ITNative))) [] +-- | tc = return $ PCon (UN "Int") 1 [] +-- toPat' (Constant (AType ATFloat)) [] | tc = return $ PCon (UN "Float") 2 [] +-- toPat' (Constant (AType (ATInt ITChar))) [] | tc = return $ PCon (UN "Char") 3 [] +-- toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 [] +-- toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 [] +-- toPat' (Constant (AType (ATInt ITBig))) [] +-- | tc = return $ PCon (UN "Integer") 6 [] +-- toPat' (Constant (AType (ATInt (ITFixed n)))) [] +-- | tc = return $ PCon (UN (fixedN n)) (7 + fromEnum n) [] -- 7-10 inclusive + toPat' (P Bound n ty) [] = -- trace (show (n, ty)) $ + do ns <- get + if n `elem` ns + then return PAny + else do put (n : ns) + return (PV n ty) + toPat' (App f a) args = toPat' f (a : args) + toPat' (Constant (AType _)) [] = return PTyPat + toPat' (Constant StrType) [] = return PTyPat + toPat' (Constant PtrType) [] = return PTyPat + toPat' (Constant VoidType) [] = return PTyPat + toPat' (Constant x) [] = return $ PConst x + toPat' (Bind n (Pi t) sc) [] | reflect && noOccurrence n sc + = do t' <- toPat' t [] + sc' <- toPat' sc [] + return $ PReflected (sUN "->") (t':sc':[]) + toPat' (P _ n _) args | reflect + = do args' <- mapM (\x -> toPat' x []) args + return $ PReflected n args' + toPat' t _ = return PAny + + fixedN IT8 = "Bits8" + fixedN IT16 = "Bits16" + fixedN IT32 = "Bits32" + fixedN IT64 = "Bits64" + + +data Partition = Cons [Clause] + | Vars [Clause] + deriving Show + +isVarPat (PV _ _ : ps , _) = True +isVarPat (PAny : ps , _) = True +isVarPat (PTyPat : ps , _) = True +isVarPat _ = False + +isConPat (PCon _ _ _ : ps, _) = True +isConPat (PReflected _ _ : ps, _) = True +isConPat (PSuc _ : ps, _) = True +isConPat (PConst _ : ps, _) = True +isConPat _ = False + +partition :: [Clause] -> [Partition] +partition [] = [] +partition ms@(m : _) + | isVarPat m = let (vars, rest) = span isVarPat ms in + Vars vars : partition rest + | isConPat m = let (cons, rest) = span isConPat ms in + Cons cons : partition rest +partition xs = error $ "Partition " ++ show xs + +-- reorder the patterns so that the one with most distinct names +-- comes next. Take rightmost first, otherwise (i.e. pick value rather +-- than dependency) + +order :: [Name] -> [Clause] -> ([Name], [Clause]) +order [] cs = ([], cs) +order ns [] = (ns, []) +order ns cs = let patnames = transpose (map (zip ns) (map fst cs)) + pats' = transpose (sortBy moreDistinct (reverse patnames)) in + (getNOrder pats', zipWith rebuild pats' cs) + where + getNOrder [] = error $ "Failed order on " ++ show (ns, cs) + getNOrder (c : _) = map fst c + + rebuild patnames clause = (map snd patnames, snd clause) + + moreDistinct xs ys = compare (numNames [] (map snd ys)) + (numNames [] (map snd xs)) + + numNames xs (PCon n _ _ : ps) + | not (Left n `elem` xs) = numNames (Left n : xs) ps + numNames xs (PConst c : ps) + | not (Right c `elem` xs) = numNames (Right c : xs) ps + numNames xs (_ : ps) = numNames xs ps + numNames xs [] = length xs + +match :: [Name] -> [Clause] -> SC -- error case + -> State CS SC +match [] (([], ret) : xs) err + = do (ts, v, ntys) <- get + put (ts ++ (map (fst.snd) xs), v, ntys) + case snd ret of + Impossible -> return ImpossibleCase + tm -> return $ STerm tm -- run out of arguments +match vs cs err = do let ps = partition cs + mixture vs ps err + +mixture :: [Name] -> [Partition] -> SC -> State CS SC +mixture vs [] err = return err +mixture vs (Cons ms : ps) err = do fallthrough <- mixture vs ps err + conRule vs ms fallthrough +mixture vs (Vars ms : ps) err = do fallthrough <- mixture vs ps err + varRule vs ms fallthrough + +data ConType = CName Name Int -- named constructor + | CFn Name -- reflected function name + | CSuc -- n+1 + | CConst Const -- constant, not implemented yet + deriving (Show, Eq) + +data Group = ConGroup ConType -- Constructor + [([Pat], Clause)] -- arguments and rest of alternative + deriving Show + +conRule :: [Name] -> [Clause] -> SC -> State CS SC +conRule (v:vs) cs err = do groups <- groupCons cs + caseGroups (v:vs) groups err + +caseGroups :: [Name] -> [Group] -> SC -> State CS SC +caseGroups (v:vs) gs err = do g <- altGroups gs + return $ Case v (sort g) + where + altGroups [] = return [DefaultCase err] + altGroups (ConGroup (CName n i) args : cs) + = do g <- altGroup n i args + rest <- altGroups cs + return (g : rest) + altGroups (ConGroup (CFn n) args : cs) + = do g <- altFnGroup n args + rest <- altGroups cs + return (g : rest) + altGroups (ConGroup CSuc args : cs) + = do g <- altSucGroup args + rest <- altGroups cs + return (g : rest) + altGroups (ConGroup (CConst c) args : cs) + = do g <- altConstGroup c args + rest <- altGroups cs + return (g : rest) + + altGroup n i gs = do (newArgs, nextCs) <- argsToAlt gs + matchCs <- match (newArgs ++ vs) nextCs err + return $ ConCase n i newArgs matchCs + altFnGroup n gs = do (newArgs, nextCs) <- argsToAlt gs + matchCs <- match (newArgs ++ vs) nextCs err + return $ FnCase n newArgs matchCs + altSucGroup gs = do ([newArg], nextCs) <- argsToAlt gs + matchCs <- match (newArg:vs) nextCs err + return $ SucCase newArg matchCs + altConstGroup n gs = do (_, nextCs) <- argsToAlt gs + matchCs <- match vs nextCs err + return $ ConstCase n matchCs + +argsToAlt :: [([Pat], Clause)] -> State CS ([Name], [Clause]) +argsToAlt [] = return ([], []) +argsToAlt rs@((r, m) : rest) + = do newArgs <- getNewVars r + return (newArgs, addRs rs) + where + getNewVars [] = return [] + getNewVars ((PV n t) : ns) = do v <- getVar "e" + (cs, i, ntys) <- get + put (cs, i, (v, t) : ntys) + nsv <- getNewVars ns + return (v : nsv) + getNewVars (PAny : ns) = do v <- getVar "i" + nsv <- getNewVars ns + return (v : nsv) + getNewVars (PTyPat : ns) = do v <- getVar "t" + nsv <- getNewVars ns + return (v : nsv) + getNewVars (_ : ns) = do v <- getVar "e" + nsv <- getNewVars ns + return (v : nsv) + addRs [] = [] + addRs ((r, (ps, res)) : rs) = ((r++ps, res) : addRs rs) + + uniq i (UN n) = MN i n + uniq i n = n + +getVar :: String -> State CS Name +getVar b = do (t, v, ntys) <- get; put (t, v+1, ntys); return (sMN v b) + +groupCons :: [Clause] -> State CS [Group] +groupCons cs = gc [] cs + where + gc acc [] = return acc + gc acc ((p : ps, res) : cs) = + do acc' <- addGroup p ps res acc + gc acc' cs + addGroup p ps res acc = case p of + PCon con i args -> return $ addg (CName con i) args (ps, res) acc + PConst cval -> return $ addConG cval (ps, res) acc + PSuc n -> return $ addg CSuc [n] (ps, res) acc + PReflected fn args -> return $ addg (CFn fn) args (ps, res) acc + pat -> fail $ show pat ++ " is not a constructor or constant (can't happen)" + + addg c conargs res [] + = [ConGroup c [(conargs, res)]] + addg c conargs res (g@(ConGroup c' cs):gs) + | c == c' = ConGroup c (cs ++ [(conargs, res)]) : gs + | otherwise = g : addg c conargs res gs + + addConG con res [] = [ConGroup (CConst con) [([], res)]] + addConG con res (g@(ConGroup (CConst n) cs) : gs) + | con == n = ConGroup (CConst n) (cs ++ [([], res)]) : gs +-- | otherwise = g : addConG con res gs + addConG con res (g : gs) = g : addConG con res gs + +varRule :: [Name] -> [Clause] -> SC -> State CS SC +varRule (v : vs) alts err = + do alts' <- mapM (repVar v) alts + match vs alts' err + where + repVar v (PV p ty : ps , (lhs, res)) + = do (cs, i, ntys) <- get + put (cs, i, (v, ty) : ntys) + return (ps, (lhs, subst p (P Bound v ty) res)) + repVar v (PAny : ps , res) = return (ps, res) + repVar v (PTyPat : ps , res) = return (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 + dp ms (STerm tm) = STerm (applyMaps ms tm) + dp ms (Case x alts) = Case x (map (dpa ms x) alts) + dp ms sc = sc + + dpa ms x (ConCase n i args sc) + = ConCase n i args (dp ((x, (n, args)) : ms) sc) + dpa ms x (FnCase n args sc) + = FnCase n args (dp ((x, (n, args)) : ms) sc) + dpa ms x (ConstCase c sc) = ConstCase c (dp ms sc) + dpa ms x (SucCase n sc) = SucCase n (dp ms sc) + dpa ms x (DefaultCase sc) = DefaultCase (dp ms sc) + + applyMaps ms f@(App _ _) + | (P nt cn pty, args) <- unApply f + = let args' = map (applyMaps ms) args in + applyMap ms nt cn pty args' + where + applyMap [] nt cn pty args' = mkApp (P nt cn pty) args' + applyMap ((x, (n, args)) : ms) nt cn pty args' + | 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 _ _ = False + + applyMaps ms (App f a) = App (applyMaps ms f) (applyMaps ms a) + applyMaps ms t = t + +-- FIXME: Do this for SucCase too +prune :: Bool -- ^ Convert single branches to projections (only useful at runtime) + -> SC -> SC +prune proj (Case n alts) + = let alts' = filter notErased (map pruneAlt alts) in + case alts' of + [] -> ImpossibleCase + as@[ConCase cn i args sc] -> if proj then mkProj n 0 args sc + else Case n as + as@[SucCase cn sc] -> if proj then mkProj n (-1) [cn] sc + else Case n as + as@[ConstCase _ sc] -> prune proj sc + -- Bit of a hack here! The default case will always be 0, make sure + -- it gets caught first. + [s@(SucCase _ _), DefaultCase dc] + -> Case n [ConstCase (BI 0) dc, s] + as -> Case n as + where pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc) + pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc) + pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc) + pruneAlt (SucCase n sc) = SucCase n (prune proj sc) + pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc) + + notErased (DefaultCase (STerm Erased)) = False + notErased (DefaultCase ImpossibleCase) = False + notErased _ = True + + mkProj n i [] sc = prune proj sc + mkProj n i (x : xs) sc = mkProj n (i + 1) xs (projRep x n i sc) + + -- Change every 'n' in sc to 'n-1' +-- mkProjS n cn sc = prune proj (fmap projn sc) where +-- projn pn@(P _ n' _) +-- | cn == n' = App (App (P Ref (UN "prim__subBigInt") Erased) +-- (P Bound n Erased)) (Constant (BI 1)) +-- projn t = t + + projRep :: Name -> Name -> Int -> SC -> SC + projRep arg n i (Case x alts) + | x == arg = ProjCase (Proj (P Bound n Erased) i) + (map (projRepAlt arg n i) alts) + | otherwise = Case x (map (projRepAlt arg n i) alts) + projRep arg n i (ProjCase t alts) + = ProjCase (projRepTm arg n i t) (map (projRepAlt arg n i) alts) + projRep arg n i (STerm t) = STerm (projRepTm arg n i t) + projRep arg n i c = c -- unmatched + + projRepAlt arg n i (ConCase cn t args rhs) + = ConCase cn t args (projRep arg n i rhs) + projRepAlt arg n i (FnCase cn args rhs) + = FnCase cn args (projRep arg n i rhs) + projRepAlt arg n i (ConstCase t rhs) + = ConstCase t (projRep arg n i rhs) + projRepAlt arg n i (SucCase sn rhs) + = SucCase sn (projRep arg n i rhs) + projRepAlt arg n i (DefaultCase rhs) + = DefaultCase (projRep arg n i rhs) + + projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t + +prune _ t = t + +stripLambdas :: CaseDef -> CaseDef +stripLambdas (CaseDef ns (STerm (Bind x (Lam _) sc)) tm) + = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm) +stripLambdas x = x + + + + diff --git a/src/Idris/Core/Constraints.hs b/src/Idris/Core/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Core/Constraints.hs @@ -0,0 +1,68 @@ +-- | Check universe constraints. +module Idris.Core.Constraints(ucheck) where + +import Idris.Core.TT +import Idris.Core.Typecheck + +import Control.Applicative +import Control.Arrow +import Control.Monad.Error +import Control.Monad.RWS +import Control.Monad.State +import Data.List +import Data.Maybe +import qualified Data.Map as M + +import Debug.Trace + +-- | Check that a list of universe constraints can be satisfied. +ucheck :: [(UConstraint, FC)] -> TC () +ucheck cs = acyclic rels (map fst (M.toList rels)) + where lhs (ULT l _) = l + lhs (ULE l _) = l + rels = mkRels cs M.empty + +type Relations = M.Map UExp [(UConstraint, FC)] + +mkRels :: [(UConstraint, FC)] -> Relations -> Relations +mkRels [] acc = acc +mkRels ((c, f) : cs) acc + | not (ignore c) + = case M.lookup (lhs c) acc of + Nothing -> mkRels cs (M.insert (lhs c) [(c,f)] acc) + Just rs -> mkRels cs (M.insert (lhs c) ((c,f):rs) acc) + | otherwise = mkRels cs acc + where lhs (ULT l _) = l + lhs (ULE l _) = l + ignore (ULE l r) = l == r + ignore _ = False + + +acyclic :: Relations -> [UExp] -> TC () +acyclic r cvs = checkCycle (fileFC "root") r [] 0 cvs + where + checkCycle :: FC -> Relations -> [(UExp, FC)] -> Int -> [UExp] -> TC () + checkCycle fc r path inc [] = return () + checkCycle fc r path inc (c : cs) + = do check fc path inc c + -- Remove c from r since we know there's no cycles now + let r' = M.insert c [] r + checkCycle fc r' path inc cs + + check fc path inc (UVar x) | x < 0 = return () + check fc path inc cv + | inc > 0 && cv `elem` map fst path + = Error $ At fc UniverseError + -- FIXME: Make informative + -- e.g. (Msg ("Cycle: " ++ show cv ++ ", " ++ show path)) + -- if we reach a cycle but we're at the same universe level, it's + -- fine, because they must all be equal, so stop. + | inc == 0 && cv `elem` map fst path + = return () + | otherwise = case M.lookup cv r of + Nothing -> return () + Just cs -> mapM_ (next ((cv, fc):path) inc) cs + + next path inc (ULT l r, fc) = check fc path (inc + 1) r + next path inc (ULE l r, fc) = check fc path inc r + diff --git a/src/Idris/Core/DeepSeq.hs b/src/Idris/Core/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Core/DeepSeq.hs @@ -0,0 +1,114 @@ +module Idris.Core.DeepSeq where + +import Idris.Core.TT +import Idris.Core.CaseTree + +import Control.DeepSeq + +instance NFData Name where + rnf (UN x1) = rnf x1 `seq` () + rnf (NS x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf NErased = () + rnf (SN x1) = rnf x1 `seq` () + +instance NFData SpecialName where + rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (MethodN x1) = rnf x1 `seq` () + rnf (CaseN x1) = rnf x1 `seq` () + rnf (ElimN x1) = rnf x1 `seq` () + +instance NFData Raw where + rnf (Var x1) = rnf x1 `seq` () + rnf (RBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf RType = () + rnf (RForce x1) = rnf x1 `seq` () + rnf (RConstant x1) = x1 `seq` () + +instance NFData FC where + rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + +instance NFData Err where + rnf (Msg x1) = rnf x1 `seq` () + rnf (InternalMsg x1) = rnf x1 `seq` () + rnf (CantUnify x1 x2 x3 x4 x5 x6) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () + rnf (InfiniteUnify x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (CantConvert x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (UnifyScope x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (CantInferType x1) = rnf x1 `seq` () + rnf (NonFunctionType x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (CantIntroduce x1) = rnf x1 `seq` () + rnf (NoSuchVariable x1) = rnf x1 `seq` () + rnf (NoTypeDecl x1) = rnf x1 `seq` () + rnf (NotInjective x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (CantResolve x1) = rnf x1 `seq` () + rnf (CantResolveAlts x1) = rnf x1 `seq` () + rnf (IncompleteTerm x1) = rnf x1 `seq` () + rnf UniverseError = () + rnf ProgramLineComment = () + rnf (Inaccessible x1) = rnf x1 `seq` () + rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` () + rnf (AlreadyDefined x1) = rnf x1 `seq` () + rnf (ProofSearchFail x1) = rnf x1 `seq` () + rnf (NoRewriting x1) = rnf x1 `seq` () + rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (Elaborating x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (ProviderError x1) = rnf x1 `seq` () + rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` () + +instance (NFData b) => NFData (Binder b) where + rnf (Lam x1) = rnf x1 `seq` () + rnf (Pi x1) = rnf x1 `seq` () + rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (Hole x1) = rnf x1 `seq` () + rnf (GHole x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (Guess x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PVar x1) = rnf x1 `seq` () + rnf (PVTy x1) = rnf x1 `seq` () + +instance NFData UExp where + rnf (UVar x1) = rnf x1 `seq` () + rnf (UVal x1) = rnf x1 `seq` () + +instance NFData NameType where + rnf Bound = () + rnf Ref = () + rnf (DCon x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` () + +instance (NFData n) => NFData (TT n) where + rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (V x1) = rnf x1 `seq` () + rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (Constant x1) = x1 `seq` () + rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf Erased = () + rnf Impossible = () + rnf (TType x1) = rnf x1 `seq` () + +instance (NFData t) => NFData (SC' t) where + rnf (Case x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (ProjCase x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (STerm x1) = rnf x1 `seq` () + rnf (UnmatchedCase x1) = rnf x1 `seq` () + rnf ImpossibleCase = () + +instance (NFData t) => NFData (CaseAlt' t) where + rnf (ConCase x1 x2 x3 x4) + = x1 `seq` x2 `seq` x3 `seq` rnf x4 `seq` () + rnf (FnCase x1 x2 x3) = x1 `seq` x2 `seq` rnf x3 `seq` () + rnf (ConstCase x1 x2) = x1 `seq` rnf x2 `seq` () + rnf (SucCase x1 x2) = x1 `seq` rnf x2 `seq` () + rnf (DefaultCase x1) = rnf x1 `seq` () diff --git a/src/Idris/Core/Elaborate.hs b/src/Idris/Core/Elaborate.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Core/Elaborate.hs @@ -0,0 +1,710 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-} + +{- A high level language of tactic composition, for building + elaborators from a high level language into the core theory. + + This is our interface to proof construction, rather than + ProofState, because this gives us a language to build derived + tactics out of the primitives. +-} + +module Idris.Core.Elaborate(module Idris.Core.Elaborate, + module Idris.Core.ProofState) where + +import Idris.Core.ProofState +import Idris.Core.TT +import Idris.Core.Evaluate +import Idris.Core.Typecheck +import Idris.Core.Unify +import Idris.Core.DeepSeq + +import Control.DeepSeq +import Control.Monad.State.Strict +import Data.Char +import Data.List +import Debug.Trace + +import Util.Pretty hiding (fill) + +-- I don't really want this here, but it's useful for the test shell +data Command = Theorem Name Raw + | Eval Raw + | Quit + | Print Name + | Tac (Elab ()) + +data ElabState aux = ES (ProofState, aux) String (Maybe (ElabState aux)) + deriving Show + +type Elab' aux a = StateT (ElabState aux) TC a +type Elab a = Elab' () a + +proof :: ElabState aux -> ProofState +proof (ES (p, _) _ _) = p + +-- Insert a 'proofSearchFail' error if necessary to shortcut any further +-- fruitless searching +proofFail :: Elab' aux a -> Elab' aux a +proofFail e = do s <- get + case runStateT e s of + OK (a, s') -> do put s' + return $! a + Error err -> lift $ Error (ProofSearchFail err) + +explicit :: Name -> Elab' aux () +explicit n = do ES (p, a) s m <- get + let p' = p { dontunify = n : dontunify p } + put (ES (p', a) s m) + +saveState :: Elab' aux () +saveState = do e@(ES p s _) <- get + put (ES p s (Just e)) + +loadState :: Elab' aux () +loadState = do (ES p s e) <- get + case e of + Just st -> put st + _ -> fail "Nothing to undo" + +getNameFrom :: Name -> Elab' aux Name +getNameFrom n = do (ES (p, a) s e) <- get + let next = nextname p + let p' = p { nextname = next + 1 } + put (ES (p', a) s e) + let n' = case n of + UN x -> MN (next+100) x + MN i x -> if i == 99999 + then MN (next+500) x + else MN (next+100) x + NS (UN x) s -> MN (next+100) x + return $! n' + +setNextName :: Elab' aux () +setNextName = do env <- get_env + ES (p, a) s e <- get + let pargs = map fst (getArgTys (ptype p)) + initNextNameFrom (pargs ++ map fst env) + +initNextNameFrom :: [Name] -> Elab' aux () +initNextNameFrom ns = do ES (p, a) s e <- get + let n' = maxName (nextname p) ns + put (ES (p { nextname = n' }, a) s e) + where + maxName m ((MN i _) : xs) = maxName (max m i) xs + maxName m (_ : xs) = maxName m xs + maxName m [] = m + 1 + +errAt :: String -> Name -> Elab' aux a -> Elab' aux a +errAt thing n elab = do s <- get + case runStateT elab s of + OK (a, s') -> do put s' + return $! a + Error (At f e) -> + lift $ Error (At f (Elaborating thing n e)) + Error e -> lift $ Error (Elaborating thing n e) + +erun :: FC -> Elab' aux a -> Elab' aux a +erun f elab = do s <- get + case runStateT elab s of + OK (a, s') -> do put s' + return $! a + Error (ProofSearchFail (At f e)) + -> lift $ Error (ProofSearchFail (At f e)) + Error (At f e) -> lift $ Error (At f e) + Error e -> lift $ Error (At f e) + +runElab :: aux -> Elab' aux a -> ProofState -> TC (a, ElabState aux) +runElab a e ps = runStateT e (ES (ps, a) "" Nothing) + +execElab :: aux -> Elab' aux a -> ProofState -> TC (ElabState aux) +execElab a e ps = execStateT e (ES (ps, a) "" Nothing) + +initElaborator :: Name -> Context -> Type -> ProofState +initElaborator = newProof + +elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String) +elaborate ctxt n ty d elab = do let ps = initElaborator n ctxt ty + (a, ES ps' str _) <- runElab d elab ps + return $! (a, str) + +force_term :: Elab' aux () +force_term = do ES (ps, a) l p <- get + put (ES (ps { pterm = force (pterm ps) }, a) l p) + +updateAux :: (aux -> aux) -> Elab' aux () +updateAux f = do ES (ps, a) l p <- get + put (ES (ps, f a) l p) + +getAux :: Elab' aux aux +getAux = do ES (ps, a) _ _ <- get + return $! a + +unifyLog :: Bool -> Elab' aux () +unifyLog log = do ES (ps, a) l p <- get + put (ES (ps { unifylog = log }, a) l p) + +getUnifyLog :: Elab' aux Bool +getUnifyLog = do ES (ps, a) l p <- get + return (unifylog ps) + +processTactic' t = do ES (p, a) logs prev <- get + (p', log) <- lift $ processTactic t p + put (ES (p', a) (logs ++ log) prev) + return $! () + +-- Some handy gadgets for pulling out bits of state + +-- get the global context +get_context :: Elab' aux Context +get_context = do ES p _ _ <- get + return $! (context (fst p)) + +-- update the context +-- (should only be used for adding temporary definitions or all sorts of +-- stuff could go wrong) +set_context :: Context -> Elab' aux () +set_context ctxt = do ES (p, a) logs prev <- get + put (ES (p { context = ctxt }, a) logs prev) + +-- get the proof term +get_term :: Elab' aux Term +get_term = do ES p _ _ <- get + return $! (pterm (fst p)) + +-- get the proof term +update_term :: (Term -> Term) -> Elab' aux () +update_term f = do ES (p,a) logs prev <- get + let p' = p { pterm = f (pterm p) } + put (ES (p', a) logs prev) + +-- get the local context at the currently in focus hole +get_env :: Elab' aux Env +get_env = do ES p _ _ <- get + lift $ envAtFocus (fst p) + +get_holes :: Elab' aux [Name] +get_holes = do ES p _ _ <- get + return $! (holes (fst p)) + +get_probs :: Elab' aux Fails +get_probs = do ES p _ _ <- get + return $! (problems (fst p)) + +-- get the current goal type +goal :: Elab' aux Type +goal = do ES p _ _ <- get + b <- lift $ goalAtFocus (fst p) + return $! (binderTy b) + +-- Get the guess at the current hole, if there is one +get_guess :: Elab' aux Type +get_guess = do ES p _ _ <- get + b <- lift $ goalAtFocus (fst p) + case b of + Guess t v -> return $! v + _ -> fail "Not a guess" + +-- typecheck locally +get_type :: Raw -> Elab' aux Type +get_type tm = do ctxt <- get_context + env <- get_env + (val, ty) <- lift $ check ctxt env tm + return $! (finalise ty) + +get_type_val :: Raw -> Elab' aux (Term, Type) +get_type_val tm = do ctxt <- get_context + env <- get_env + (val, ty) <- lift $ check ctxt env tm + return $! (finalise val, finalise ty) + +-- get holes we've deferred for later definition +get_deferred :: Elab' aux [Name] +get_deferred = do ES p _ _ <- get + return $! (deferred (fst p)) + +checkInjective :: (Term, Term, Term) -> Elab' aux () +checkInjective (tm, l, r) = do ctxt <- get_context + if isInj ctxt tm then return $! () + else lift $ tfail (NotInjective tm l r) + where isInj ctxt (P _ n _) + | isConName n ctxt = True + isInj ctxt (App f a) = isInj ctxt f + isInj ctxt (Constant _) = True + isInj ctxt (TType _) = True + isInj ctxt (Bind _ (Pi _) sc) = True + isInj ctxt _ = False + +-- get instance argument names +get_instances :: Elab' aux [Name] +get_instances = do ES p _ _ <- get + return $! (instances (fst p)) + +-- given a desired hole name, return a unique hole name +unique_hole = unique_hole' False + +unique_hole' :: Bool -> Name -> Elab' aux Name +unique_hole' reusable n + = do ES p _ _ <- get + let bs = bound_in (pterm (fst p)) ++ + bound_in (ptype (fst p)) + let nouse = holes (fst p) ++ bs ++ dontunify (fst p) ++ usedns (fst p) + n' <- return $! uniqueNameCtxt (context (fst p)) n nouse + ES (p, a) s u <- get + case n' of + MN i _ -> when (i >= nextname p) $ + put (ES (p { nextname = i + 1 }, a) s u) + _ -> return $! () + return $! n' + where + bound_in (Bind n b sc) = n : bi b ++ bound_in sc + where + bi (Let t v) = bound_in t ++ bound_in v + bi (Guess t v) = bound_in t ++ bound_in v + bi b = bound_in (binderTy b) + bound_in (App f a) = bound_in f ++ bound_in a + bound_in _ = [] + +elog :: String -> Elab' aux () +elog str = do ES p logs prev <- get + put (ES p (logs ++ str ++ "\n") prev) + +getLog :: Elab' aux String +getLog = do ES p logs _ <- get + return $! logs + +-- The primitives, from ProofState + +attack :: Elab' aux () +attack = processTactic' Attack + +claim :: Name -> Raw -> Elab' aux () +claim n t = processTactic' (Claim n t) + +exact :: Raw -> Elab' aux () +exact t = processTactic' (Exact t) + +fill :: Raw -> Elab' aux () +fill t = processTactic' (Fill t) + +match_fill :: Raw -> Elab' aux () +match_fill t = processTactic' (MatchFill t) + +prep_fill :: Name -> [Name] -> Elab' aux () +prep_fill n ns = processTactic' (PrepFill n ns) + +complete_fill :: Elab' aux () +complete_fill = processTactic' CompleteFill + +solve :: Elab' aux () +solve = processTactic' Solve + +start_unify :: Name -> Elab' aux () +start_unify n = processTactic' (StartUnify n) + +end_unify :: Elab' aux () +end_unify = processTactic' EndUnify + +regret :: Elab' aux () +regret = processTactic' Regret + +compute :: Elab' aux () +compute = processTactic' Compute + +computeLet :: Name -> Elab' aux () +computeLet n = processTactic' (ComputeLet n) + +simplify :: Elab' aux () +simplify = processTactic' Simplify + +hnf_compute :: Elab' aux () +hnf_compute = processTactic' HNF_Compute + +eval_in :: Raw -> Elab' aux () +eval_in t = processTactic' (EvalIn t) + +check_in :: Raw -> Elab' aux () +check_in t = processTactic' (CheckIn t) + +intro :: Maybe Name -> Elab' aux () +intro n = processTactic' (Intro n) + +introTy :: Raw -> Maybe Name -> Elab' aux () +introTy ty n = processTactic' (IntroTy ty n) + +forall :: Name -> Raw -> Elab' aux () +forall n t = processTactic' (Forall n t) + +letbind :: Name -> Raw -> Raw -> Elab' aux () +letbind n t v = processTactic' (LetBind n t v) + +expandLet :: Name -> Term -> Elab' aux () +expandLet n v = processTactic' (ExpandLet n v) + +rewrite :: Raw -> Elab' aux () +rewrite tm = processTactic' (Rewrite tm) + +induction :: Name -> Elab' aux () +induction nm = processTactic' (Induction nm) + +equiv :: Raw -> Elab' aux () +equiv tm = processTactic' (Equiv tm) + +patvar :: Name -> Elab' aux () +patvar n = do env <- get_env + hs <- get_holes + if (n `elem` map fst env) then do apply (Var n) []; solve + else do n' <- case n of + UN _ -> return $! n + MN _ _ -> unique_hole n + NS _ _ -> return $! n + processTactic' (PatVar n') + +patbind :: Name -> Elab' aux () +patbind n = processTactic' (PatBind n) + +focus :: Name -> Elab' aux () +focus n = processTactic' (Focus n) + +movelast :: Name -> Elab' aux () +movelast n = processTactic' (MoveLast n) + +matchProblems :: Elab' aux () +matchProblems = processTactic' MatchProblems + +unifyProblems :: Elab' aux () +unifyProblems = processTactic' UnifyProblems + +defer :: Name -> Elab' aux () +defer n = do n' <- unique_hole n + processTactic' (Defer n') + +deferType :: Name -> Raw -> [Name] -> Elab' aux () +deferType n ty ns = processTactic' (DeferType n ty ns) + +instanceArg :: Name -> Elab' aux () +instanceArg n = processTactic' (Instance n) + +setinj :: Name -> Elab' aux () +setinj n = processTactic' (SetInjective n) + +proofstate :: Elab' aux () +proofstate = processTactic' ProofState + +reorder_claims :: Name -> Elab' aux () +reorder_claims n = processTactic' (Reorder n) + +qed :: Elab' aux Term +qed = do processTactic' QED + ES p _ _ <- get + return $! (pterm (fst p)) + +undo :: Elab' aux () +undo = processTactic' Undo + +-- | Prepare to apply a function by creating holes to be filled by the arguments +prepare_apply :: Raw -- ^ The operation being applied + -> [Bool] -- ^ Whether arguments are implicit + -> Elab' aux [(Name, Name)] -- ^ The names of the arguments and their holes to be filled with elaborated argument values +prepare_apply fn imps = + do ty <- get_type fn + ctxt <- get_context + env <- get_env + -- let claims = getArgs ty imps + -- claims <- mkClaims (normalise ctxt env ty) imps [] + claims <- mkClaims (finalise ty) imps [] (map fst env) + ES (p, a) s prev <- get + -- reverse the claims we made so that args go left to right + let n = length (filter not imps) + let (h : hs) = holes p + put (ES (p { holes = h : (reverse (take n hs) ++ drop n hs) }, a) s prev) + return $! claims + where + mkClaims :: Type -- ^ The type of the operation being applied + -> [Bool] -- ^ Whether the arguments are implicit + -> [(Name, Name)] -- ^ Accumulator for produced claims + -> [Name] -- ^ Hypotheses + -> Elab' aux [(Name, Name)] -- ^ The names of the arguments and their holes, resp. + mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs = + do let t = rebind hs t_in + n <- getNameFrom (mkMN n') +-- when (null claims) (start_unify n) + let sc' = instantiate (P Bound n t) sc +-- trace ("CLAIMING " ++ show (n, t) ++ " with " ++ show (fn, hs)) $ + claim n (forget t) + when i (movelast n) + mkClaims sc' is ((n', n) : claims) hs + mkClaims t [] claims _ = return $! (reverse claims) + mkClaims _ _ _ _ + | Var n <- fn + = do ctxt <- get_context + case lookupTy n ctxt of + [] -> lift $ tfail $ NoSuchVariable n + _ -> lift $ tfail $ TooManyArguments n + | otherwise = fail $ "Too many arguments for " ++ show fn + + doClaim ((i, _), n, t) = do claim n t + when i (movelast n) + + mkMN n@(MN i _) = n + mkMN n@(UN x) = MN 99999 x + mkMN n@(SN s) = sMN 99999 (show s) + mkMN (NS n xs) = NS (mkMN n) xs + + rebind hs (Bind n t sc) + | n `elem` hs = let n' = uniqueName n hs in + Bind n' (fmap (rebind hs) t) (rebind (n':hs) sc) + | otherwise = Bind n (fmap (rebind hs) t) (rebind (n:hs) sc) + rebind hs (App f a) = App (rebind hs f) (rebind hs a) + rebind hs t = t + +apply, match_apply :: Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)] +apply = apply' fill +match_apply = apply' match_fill + +apply' :: (Raw -> Elab' aux ()) -> Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)] +apply' fillt fn imps = + do args <- prepare_apply fn (map fst imps) + -- _Don't_ solve the arguments we're specifying by hand. + -- (remove from unified list before calling end_unify) + -- HMMM: Actually, if we get it wrong, the typechecker will complain! + -- so do nothing + hs <- get_holes + ES (p, a) s prev <- get + let dont = head hs : dontunify p ++ + if null imps then [] -- do all we can + else + map fst (filter (not . snd) (zip (map snd args) (map fst imps))) + let (n, hunis) = -- trace ("AVOID UNIFY: " ++ show (fn, dont) ++ "\n" ++ show ptm) $ + unified p + let unify = -- trace ("Not done " ++ show hs) $ + 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) + fillt (raw_apply fn (map (Var . snd) args)) +-- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $ + end_unify + return $! (map (\(argName, argHole) -> (argName, updateUnify unify argHole)) args) + where updateUnify us n = case lookup n us of + Just (P _ t _) -> t + _ -> n + +apply2 :: Raw -> [Maybe (Elab' aux ())] -> Elab' aux () +apply2 fn elabs = + do args <- prepare_apply fn (map isJust elabs) + fill (raw_apply fn (map (Var . snd) args)) + elabArgs (map snd args) elabs + ES (p, a) s prev <- get + let (n, hs) = unified p + end_unify + solve + where elabArgs [] [] = return $! () + elabArgs (n:ns) (Just e:es) = do focus n; e + elabArgs ns es + elabArgs (n:ns) (_:es) = elabArgs ns es + + isJust (Just _) = False + isJust _ = True + +apply_elab :: Name -> [Maybe (Int, Elab' aux ())] -> Elab' aux () +apply_elab n args = + do ty <- get_type (Var n) + ctxt <- get_context + env <- get_env + claims <- doClaims (hnf ctxt env ty) args [] + prep_fill n (map fst claims) + let eclaims = sortBy (\ (_, x) (_,y) -> priOrder x y) claims + elabClaims [] False claims + complete_fill + end_unify + where + priOrder Nothing Nothing = EQ + priOrder Nothing _ = LT + priOrder _ Nothing = GT + priOrder (Just (x, _)) (Just (y, _)) = compare x y + + doClaims (Bind n' (Pi t) sc) (i : is) claims = + do n <- unique_hole (mkMN n') + when (null claims) (start_unify n) + let sc' = instantiate (P Bound n t) sc + claim n (forget t) + case i of + Nothing -> return $! () + Just _ -> -- don't solve by unification as there is an explicit value + do ES (p, a) s prev <- get + put (ES (p { dontunify = n : dontunify p }, a) s prev) + doClaims sc' is ((n, i) : claims) + doClaims t [] claims = return $! (reverse claims) + doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n + + elabClaims failed r [] + | null failed = return $! () + | otherwise = if r then elabClaims [] False failed + else return $! () + elabClaims failed r ((n, Nothing) : xs) = elabClaims failed r xs + elabClaims failed r (e@(n, Just (_, elaboration)) : xs) + | r = try (do ES p _ _ <- get + focus n; elaboration; elabClaims failed r xs) + (elabClaims (e : failed) r xs) + | otherwise = do ES p _ _ <- get + focus n; elaboration; elabClaims failed r xs + + mkMN n@(MN _ _) = n + mkMN n@(UN x) = MN 0 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 :: Name -> Elab' aux () +checkPiGoal n + = do g <- goal + case g of + Bind _ (Pi _) _ -> return () + _ -> do a <- getNameFrom (sMN 0 "pargTy") + b <- getNameFrom (sMN 0 "pretTy") + f <- getNameFrom (sMN 0 "pf") + claim a RType + claim b RType + claim f (RBind n (Pi (Var a)) (Var b)) + movelast a + movelast b + fill (Var f) + solve + focus f + +simple_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux () +simple_app fun arg appstr = + do a <- getNameFrom (sMN 0 "argTy") + b <- getNameFrom (sMN 0 "retTy") + f <- getNameFrom (sMN 0 "f") + s <- getNameFrom (sMN 0 "s") + claim a RType + claim b RType + claim f (RBind (sMN 0 "aX") (Pi (Var a)) (Var b)) + tm <- get_term + start_unify s + claim s (Var a) + prep_fill f [s] + focus f; fun + focus s; arg + tm <- get_term + ps <- get_probs + complete_fill + hs <- get_holes + env <- get_env + -- We don't need a and b in the hole queue any more since they were + -- just for checking f, so discard them if they are still there. + -- If they haven't been solved, regret will fail + when (a `elem` hs) $ do focus a; regretWith (CantInferType appstr) + when (b `elem` hs) $ do focus b; regretWith (CantInferType appstr) + end_unify + where regretWith err = try regret + (lift $ tfail err) + +-- Abstract over an argument of unknown type, giving a name for the hole +-- which we'll fill with the argument type too. +arg :: Name -> Name -> Elab' aux () +arg n tyhole = do ty <- unique_hole tyhole + claim ty RType + forall n (Var ty) + +-- try a tactic, if it adds any unification problem, return an error +no_errors :: Elab' aux () -> Maybe Err -> Elab' aux () +no_errors tac err + = do ps <- get_probs + s <- get + case err of + Nothing -> tac + Just e -> -- update the error, if there is one. + case runStateT tac s of + Error _ -> lift $ Error e + OK (a, s') -> do put s' + return a + 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 + +try' :: Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a +try' t1 t2 proofSearch + = do s <- get + ps <- get_probs + 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 + Error e2 -> if score e1 >= score e2 + then lift (tfail e1) + else lift (tfail e2) + else lift (tfail e1) + where recoverableErr err@(CantUnify r x y _ _ _) + = -- traceWhen r (show err) $ + r || proofSearch + recoverableErr (CantSolveGoal _ _) = False + recoverableErr (ProofSearchFail _) = False + recoverableErr _ = True + +tryWhen :: Bool -> Elab' aux a -> Elab' aux a -> Elab' aux a +tryWhen True a b = try a b +tryWhen False a b = a + + +-- Try a selection of tactics. Exactly one must work, all others must fail +tryAll :: [(Elab' aux a, String)] -> Elab' aux a +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] pmax _ [] = res + tryAll' (_:_) pmax _ [] = cantResolve + tryAll' [] pmax (f, _) [] = f + tryAll' cs pmax f (x:xs) + = do s <- get + ps <- get_probs + 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 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 pmax zok ps x s + = case runStateT x s of + OK (v, s'@(ES (p, _) _ _)) -> + 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, 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 diff --git a/src/Idris/Core/Evaluate.hs b/src/Idris/Core/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Core/Evaluate.hs @@ -0,0 +1,933 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, + PatternGuards #-} + +module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll, + rt_simplify, simplify, specialise, hnf, convEq, convEq', + Def(..), CaseInfo(..), CaseDefs(..), + Accessibility(..), Totality(..), PReason(..), MetaInformation(..), + Context, initContext, ctxtAlist, uconstraints, next_tvar, + addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl, + addDatatype, addCasedef, simplifyCasedef, addOperator, + lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal, + mapDefCtxt, + lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName, + Value(..), Quote(..), initEval, uniqueNameCtxt) where + +import Debug.Trace +import Control.Monad.State -- not Strict! +import qualified Data.Binary as B +import Data.Binary hiding (get, put) + +import Idris.Core.TT +import Idris.Core.CaseTree + +data EvalState = ES { limited :: [(Name, Int)], + nexthole :: Int } + deriving Show + +type Eval a = State EvalState a + +data EvalOpt = Spec + | HNF + | Simplify + | AtREPL + | RunTT + deriving (Show, Eq) + +initEval = ES [] 0 + +-- VALUES (as HOAS) --------------------------------------------------------- +-- | A HOAS representation of values +data Value = VP NameType Name Value + | VV Int + -- True for Bool indicates safe to reduce + | VBind Bool Name (Binder Value) (Value -> Eval Value) + -- For frozen let bindings when simplifying + | VBLet Int Name Value Value Value + | VApp Value Value + | VType UExp + | VErased + | VImpossible + | VConstant Const + | VProj Value Int +-- | VLazy Env [Value] Term + | VTmp Int + +instance Show Value where + show x = show $ evalState (quote 100 x) initEval + +instance Show (a -> b) where + show x = "<>" + +-- THE EVALUATOR ------------------------------------------------------------ + +-- The environment is assumed to be "locally named" - i.e., not de Bruijn +-- indexed. +-- i.e. it's an intermediate environment that we have while type checking or +-- while building a proof. + +-- | Normalise fully type checked terms (so, assume all names/let bindings resolved) +normaliseC :: Context -> Env -> TT Name -> TT Name +normaliseC ctxt env t + = evalState (do val <- eval False ctxt [] env t [] + quote 0 val) initEval + +normaliseAll :: Context -> Env -> TT Name -> TT Name +normaliseAll ctxt env t + = evalState (do val <- eval False ctxt [] env t [AtREPL] + quote 0 val) initEval + +normalise :: Context -> Env -> TT Name -> TT Name +normalise = normaliseTrace False + +normaliseTrace :: Bool -> Context -> Env -> TT Name -> TT Name +normaliseTrace tr ctxt env t + = evalState (do val <- eval tr ctxt [] (map finalEntry env) (finalise t) [] + quote 0 val) initEval + +specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> TT Name +specialise ctxt env limits t + = evalState (do val <- eval False ctxt [] + (map finalEntry env) (finalise t) + [Spec] + quote 0 val) (initEval { limited = limits }) + +-- | Like normalise, but we only reduce functions that are marked as okay to +-- inline (and probably shouldn't reduce lets?) +-- 20130908: now only used to reduce for totality checking. Inlining should +-- be done elsewhere. + +simplify :: Context -> Env -> TT Name -> TT Name +simplify ctxt env t + = evalState (do val <- eval False ctxt [(sUN "lazy", 0), + (sUN "assert_smaller", 0), + (sUN "assert_total", 0), + (sUN "par", 0), + (sUN "prim__syntactic_eq", 0), + (sUN "fork", 0)] + (map finalEntry env) (finalise t) + [Simplify] + quote 0 val) initEval + +-- | Simplify for run-time (i.e. basic inlining) +rt_simplify :: Context -> Env -> TT Name -> TT Name +rt_simplify ctxt env t + = evalState (do val <- eval False ctxt [(sUN "lazy", 0), + (sUN "par", 0), + (sUN "prim__syntactic_eq", 0), + (sUN "prim_fork", 0)] + (map finalEntry env) (finalise t) + [RunTT] + quote 0 val) initEval + +-- | Reduce a term to head normal form +hnf :: Context -> Env -> TT Name -> TT Name +hnf ctxt env t + = evalState (do val <- eval False ctxt [] + (map finalEntry env) + (finalise t) [HNF] + quote 0 val) initEval + + +-- unbindEnv env (quote 0 (eval ctxt (bindEnv env t))) + +finalEntry :: (Name, Binder (TT Name)) -> (Name, Binder (TT Name)) +finalEntry (n, b) = (n, fmap finalise b) + +bindEnv :: EnvTT n -> TT n -> TT n +bindEnv [] tm = tm +bindEnv ((n, Let t v):bs) tm = Bind n (NLet t v) (bindEnv bs tm) +bindEnv ((n, b):bs) tm = Bind n b (bindEnv bs tm) + +unbindEnv :: EnvTT n -> TT n -> TT n +unbindEnv [] tm = tm +unbindEnv (_:bs) (Bind n b sc) = unbindEnv bs sc + +usable :: Bool -- specialising + -> Name -> [(Name, Int)] -> Eval (Bool, [(Name, Int)]) +-- usable _ _ ns@((MN 0 "STOP", _) : _) = return (False, ns) +usable False n [] = return (True, []) +usable True n ns + = do ES ls num <- get + case lookup n ls of + Just 0 -> return (False, ns) + Just i -> return (True, ns) + _ -> return (False, ns) +usable False n ns + = case lookup n ns of + Just 0 -> return (False, ns) + Just i -> return $ (True, (n, abs (i-1)) : filter (\ (n', _) -> n/=n') ns) + _ -> return $ (True, (n, 100) : filter (\ (n', _) -> n/=n') ns) + + +deduct :: Name -> Eval () +deduct n = do ES ls num <- get + case lookup n ls of + Just i -> do put $ ES ((n, (i-1)) : + filter (\ (n', _) -> n/=n') ls) num + _ -> return () + +-- | Evaluate in a context of locally named things (i.e. not de Bruijn indexed, +-- such as we might have during construction of a proof) + +-- The (Name, Int) pair in the arguments is the maximum depth of unfolding of +-- a name. The corresponding pair in the state is the maximum number of +-- unfoldings overall. + +eval :: Bool -> Context -> [(Name, Int)] -> Env -> TT Name -> + [EvalOpt] -> Eval Value +eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where + spec = Spec `elem` opts + simpl = Simplify `elem` opts + runtime = RunTT `elem` opts + atRepl = AtREPL `elem` opts + hnf = HNF `elem` opts + + -- returns 'True' if the function should block + -- normal evaluation should return false + blockSimplify (CaseInfo inl dict) n stk + | RunTT `elem` opts + = not (inl || dict) || elem n stk + | Simplify `elem` opts + = (not (inl || dict) || elem n stk) + || (n == sUN "prim__syntactic_eq") + | otherwise = False + + getCases cd | simpl = cases_totcheck cd + | runtime = cases_runtime cd + | otherwise = cases_compiletime cd + + ev ntimes stk top env (P _ n ty) + | Just (Let t v) <- lookup n genv = ev ntimes stk top env v + ev ntimes_in stk top env (P Ref n ty) + | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty) + | otherwise + = do (u, ntimes) <- usable spec n ntimes_in + if u then + do let val = lookupDefAcc n (spec || atRepl) ctxt + case val of + [(Function _ tm, _)] | sUN "assert_total" `elem` stk -> + ev ntimes (n:stk) True env tm + [(Function _ tm, Public)] -> + ev ntimes (n:stk) True env tm + [(Function _ tm, Hidden)] -> + ev ntimes (n:stk) True env tm + [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty + return $ VP nt n vty + [(CaseOp ci _ _ _ _ cd, acc)] + | (acc /= Frozen || sUN "assert_total" `elem` stk) && + null (fst (cases_totcheck cd)) -> -- unoptimised version + let (ns, tree) = getCases cd in + if blockSimplify ci n stk + then liftM (VP Ref n) (ev ntimes stk top env ty) + else -- traceWhen runtime (show (n, ns, tree)) $ + do c <- evCase ntimes n (n:stk) top env ns [] tree + case c of + (Nothing, _) -> liftM (VP Ref n) (ev ntimes stk top env ty) + (Just v, _) -> return v + _ -> liftM (VP Ref n) (ev ntimes stk top env ty) + else liftM (VP Ref n) (ev ntimes stk top env ty) + ev ntimes stk top env (P nt n ty) + = liftM (VP nt n) (ev ntimes stk top env ty) + ev ntimes stk top env (V i) + | i < length env && i >= 0 = return $ snd (env !! i) + | otherwise = return $ VV i + ev ntimes stk top env (Bind n (Let t v) sc) + = do v' <- ev ntimes stk top env v --(finalise v) + sc' <- ev ntimes stk top ((n, v') : env) sc + wknV (-1) sc' +-- | otherwise +-- = do t' <- ev ntimes stk top env t +-- v' <- ev ntimes stk top env v --(finalise v) +-- -- use Tmp as a placeholder, then make it a variable reference +-- -- again when evaluation finished +-- hs <- get +-- let vd = nexthole hs +-- put (hs { nexthole = vd + 1 }) +-- sc' <- ev ntimes stk top (VP Bound (MN vd "vlet") VErased : env) sc +-- return $ VBLet vd n t' v' sc' + ev ntimes stk top env (Bind n (NLet t v) sc) + = do t' <- ev ntimes stk top env (finalise t) + v' <- ev ntimes stk top env (finalise v) + sc' <- ev ntimes stk top ((n, v') : env) sc + return $ VBind True n (Let t' v') (\x -> return sc') + ev ntimes stk top env (Bind n b sc) + = do b' <- vbind env b + let n' = uniqueName n (map fst env) + return $ VBind True -- (vinstances 0 sc < 2) + n' b' (\x -> ev ntimes stk False ((n, x):env) sc) + where vbind env t + = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t + -- Treat "assert_total" specially, as long as it's defined! + ev ntimes stk top env (App (App (P _ n@(UN at) _) _) arg) + | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt, + at == txt "assert_total" && not simpl + = ev ntimes (n : stk) top env arg + ev ntimes stk top env (App f a) + = do f' <- ev ntimes stk False env f + a' <- ev ntimes stk False env a + evApply ntimes stk top env [a'] f' + ev ntimes stk top env (Proj t i) + = do -- evaluate dictionaries if it means the projection works + t' <- ev ntimes stk top env t +-- tfull' <- reapply ntimes stk top env t' [] + return (doProj t' (getValArgs t')) + where doProj t' (VP (DCon _ _) _ _, args) + | i >= 0 && i < length args = args!!i + doProj t' _ = VProj t' i + + ev ntimes stk top env (Constant c) = return $ VConstant c + ev ntimes stk top env Erased = return VErased + ev ntimes stk top env Impossible = return VImpossible + ev ntimes stk top env (TType i) = return $ VType i + + evApply ntimes stk top env args (VApp f a) + = evApply ntimes stk top env (a:args) f + evApply ntimes stk top env args f + = apply ntimes stk top env f args + + reapply ntimes stk top env f@(VP Ref n ty) args + = let val = lookupDefAcc n (spec || atRepl) ctxt in + case val of + [(CaseOp ci _ _ _ _ cd, acc)] -> + let (ns, tree) = getCases cd in + do c <- evCase ntimes n (n:stk) top env ns args tree + case c of + (Nothing, _) -> return $ unload env (VP Ref n ty) args + (Just v, rest) -> evApply ntimes stk top env rest v + _ -> case args of + (a : as) -> return $ unload env f (a : as) + [] -> return f + reapply ntimes stk top env (VApp f a) args + = reapply ntimes stk top env f (a : args) + reapply ntimes stk top env v args = return v + + apply ntimes stk top env (VBind True n (Lam t) sc) (a:as) + = do a' <- sc a + app <- apply ntimes stk top env a' as + wknV (-1) app + apply ntimes_in stk top env f@(VP Ref n ty) args + | not top && hnf = case args of + [] -> return f + _ -> return $ unload env f args + | otherwise + = do (u, ntimes) <- usable spec n ntimes_in + if u then + do let val = lookupDefAcc n (spec || atRepl) ctxt + case val of + [(CaseOp ci _ _ _ _ cd, acc)] + | acc /= Frozen || sUN "assert_total" `elem` stk -> + -- unoptimised version + let (ns, tree) = getCases cd in + if blockSimplify ci n stk + then return $ unload env (VP Ref n ty) args + else -- traceWhen runtime (show (n, ns, tree)) $ + do c <- evCase ntimes n (n:stk) top env ns args tree + case c of + (Nothing, _) -> return $ unload env (VP Ref n ty) args + (Just v, rest) -> evApply ntimes stk top env rest v + [(Operator _ i op, _)] -> + if (i <= length args) + then case op (take i args) of + Nothing -> return $ unload env (VP Ref n ty) args + Just v -> evApply ntimes stk top env (drop i args) v + else return $ unload env (VP Ref n ty) args + _ -> case args of + [] -> return f + _ -> return $ unload env f args + else case args of + (a : as) -> return $ unload env f (a:as) + [] -> return f + apply ntimes stk top env f (a:as) = return $ unload env f (a:as) + apply ntimes stk top env f [] = return f + +-- specApply stk env f@(VP Ref n ty) args +-- = 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 +-- else return $ unload env f args +-- _ -> return $ unload env f args +-- specApply stk env f args = return $ unload env f args + + unload :: [(Name, Value)] -> Value -> [Value] -> Value + unload env f [] = f + unload env f (a:as) = unload env (VApp f a) as + + evCase ntimes n stk top env ns args tree + | length ns <= length args + = do let args' = take (length ns) args + let rest = drop (length ns) args + when spec $ deduct n -- successful, so deduct usages + t <- evTree ntimes stk top env (zip ns args') tree +-- (zipWith (\n , t) -> (n, t)) ns args') tree + return (t, rest) + | otherwise = return (Nothing, args) + + evTree :: [(Name, Int)] -> [Name] -> Bool -> + [(Name, Value)] -> [(Name, Value)] -> SC -> Eval (Maybe Value) + evTree ntimes stk top env amap (UnmatchedCase str) = return Nothing + evTree ntimes stk top env amap (STerm tm) + = do let etm = pToVs (map fst amap) tm + etm' <- ev ntimes stk (not (conHeaded tm)) + (amap ++ env) etm + return $ Just etm' + evTree ntimes stk top env amap (ProjCase t alts) + = do t' <- ev ntimes stk top env t + doCase ntimes stk top env amap t' alts + evTree ntimes stk top env amap (Case n alts) + = case lookup n amap of + Just v -> doCase ntimes stk top env amap v alts + _ -> return Nothing + evTree ntimes stk top env amap ImpossibleCase = return Nothing + + doCase ntimes stk top env amap v alts = + do c <- chooseAlt env v (getValArgs v) alts amap + case c of + Just (altmap, sc) -> evTree ntimes stk top env altmap sc + _ -> do c' <- chooseAlt' ntimes stk env v (getValArgs v) alts amap + case c' of + Just (altmap, sc) -> evTree ntimes stk top env altmap sc + _ -> return Nothing + + conHeaded tm@(App _ _) + | (P (DCon _ _) _ _, args) <- unApply tm = True + conHeaded t = False + + chooseAlt' ntimes stk env _ (f, args) alts amap + = do f' <- apply ntimes stk True env f args + chooseAlt env f' (getValArgs f') + alts amap + + chooseAlt :: [(Name, Value)] -> Value -> (Value, [Value]) -> [CaseAlt] -> + [(Name, Value)] -> + Eval (Maybe ([(Name, Value)], SC)) + chooseAlt env _ (VP (DCon i a) _ _, args) alts amap + | Just (ns, sc) <- findTag i alts = return $ Just (updateAmap (zip ns args) amap, sc) + | Just v <- findDefault alts = return $ Just (amap, v) + chooseAlt env _ (VP (TCon i a) _ _, args) alts amap + | Just (ns, sc) <- findTag i alts + = return $ Just (updateAmap (zip ns args) amap, sc) + | Just v <- findDefault alts = return $ Just (amap, v) + chooseAlt env _ (VConstant c, []) alts amap + | Just v <- findConst c alts = return $ Just (amap, v) + | Just (n', sub, sc) <- findSuc c alts + = return $ Just (updateAmap [(n',sub)] amap, sc) + | Just v <- findDefault alts = return $ Just (amap, v) + chooseAlt env _ (VP _ n _, args) alts amap + | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc) + chooseAlt env _ (VBind _ _ (Pi s) t, []) alts amap + | Just (ns, sc) <- findFn (sUN "->") alts + = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern + return $ Just (updateAmap (zip ns [s, t']) amap, sc) + chooseAlt _ _ _ alts amap + | Just v <- findDefault alts + = if (any fnCase alts) + then return $ Just (amap, v) + else return Nothing + | otherwise = return Nothing + + fnCase (FnCase _ _ _) = True + fnCase _ = False + + -- Replace old variable names in the map with new matches + -- (This is possibly unnecessary since we make unique names and don't + -- allow repeated variables...?) + updateAmap newm amap + = newm ++ filter (\ (x, _) -> not (elem x (map fst newm))) amap + findTag i [] = Nothing + findTag i (ConCase n j ns sc : xs) | i == j = Just (ns, sc) + findTag i (_ : xs) = findTag i xs + + findFn fn [] = Nothing + findFn fn (FnCase n ns sc : xs) | fn == n = Just (ns, sc) + findFn fn (_ : xs) = findFn fn xs + + findDefault [] = Nothing + findDefault (DefaultCase sc : xs) = Just sc + findDefault (_ : xs) = findDefault xs + + findSuc c [] = Nothing + findSuc (BI val) (SucCase n sc : _) + | val /= 0 = Just (n, VConstant (BI (val - 1)), sc) + findSuc c (_ : xs) = findSuc c xs + + findConst c [] = Nothing + findConst c (ConstCase c' v : xs) | c == c' = Just v + findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v + findConst (AType ATFloat) (ConCase n 2 [] v : xs) = Just v + findConst (AType (ATInt ITChar)) (ConCase n 3 [] v : xs) = Just v + findConst StrType (ConCase n 4 [] v : xs) = Just v + findConst PtrType (ConCase n 5 [] v : xs) = Just v + findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v + findConst (AType (ATInt (ITFixed ity))) (ConCase n tag [] v : xs) + | tag == 7 + fromEnum ity = Just v + findConst (AType (ATInt (ITVec ity count))) (ConCase n tag [] v : xs) + | tag == (fromEnum ity + 1) * 1000 + count = Just v + findConst c (_ : xs) = findConst c xs + + getValArgs tm = getValArgs' tm [] + getValArgs' (VApp f a) as = getValArgs' f (a:as) + getValArgs' f as = (f, as) + +-- tmpToV i vd (VLetHole j) | vd == j = return $ VV i +-- tmpToV i vd (VP nt n v) = liftM (VP nt n) (tmpToV i vd v) +-- tmpToV i vd (VBind n b sc) = do b' <- fmapMB (tmpToV i vd) b +-- let sc' = \x -> do x' <- sc x +-- tmpToV (i + 1) vd x' +-- return (VBind n b' sc') +-- tmpToV i vd (VApp f a) = liftM2 VApp (tmpToV i vd f) (tmpToV i vd a) +-- tmpToV i vd x = return x + +instance Eq Value where + (==) x y = getTT x == getTT y + where getTT v = evalState (quote 0 v) initEval + +class Quote a where + quote :: Int -> a -> Eval (TT Name) + +instance Quote Value where + quote i (VP nt n v) = liftM (P nt n) (quote i v) + quote i (VV x) = return $ V x + quote i (VBind _ n b sc) = do sc' <- sc (VTmp i) + b' <- quoteB b + liftM (Bind n b') (quote (i+1) sc') + where quoteB t = fmapMB (quote i) t + quote i (VBLet vd n t v sc) + = do sc' <- quote i sc + t' <- quote i t + v' <- quote i v + let sc'' = pToV (sMN vd "vlet") (addBinder sc') + return (Bind n (Let t' v') sc'') + quote i (VApp f a) = liftM2 App (quote i f) (quote i a) + quote i (VType u) = return $ TType u + quote i VErased = return $ Erased + quote i VImpossible = return $ Impossible + quote i (VProj v j) = do v' <- quote i v + return (Proj v' j) + quote i (VConstant c) = return $ Constant c + quote i (VTmp x) = return $ V (i - x - 1) + +wknV :: Int -> Value -> Eval Value +wknV i (VV x) = return $ VV (x + i) +wknV i (VBind red n b sc) = do b' <- fmapMB (wknV i) b + return $ VBind red n b' (\x -> do x' <- sc x + wknV i x') +wknV i (VApp f a) = liftM2 VApp (wknV i f) (wknV i a) +wknV i t = return t + +convEq' ctxt x y = evalStateT (convEq ctxt x y) (0, []) + +convEq :: Context -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool +convEq ctxt = ceq [] where + ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool + 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) + where + ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') + ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') + ceqB ps b b' = ceq ps (binderTy b) (binderTy b') + ceq ps (App fx ax) (App fy ay) = liftM2 (&&) (ceq ps fx fy) (ceq ps ax ay) + ceq ps (Constant x) (Constant y) = return (x == y) + ceq ps (TType x) (TType y) = do (v, cs) <- get + put (v, ULE x y : cs) + return True + ceq ps Erased _ = return True + ceq ps _ Erased = return True + ceq ps _ _ = return False + + caseeq ps (Case n cs) (Case n' cs') = caseeqA ((n,n'):ps) cs cs' + where + caseeqA ps (ConCase x i as sc : rest) (ConCase x' i' as' sc' : rest') + = do q1 <- caseeq (zip as as' ++ ps) sc sc' + q2 <- caseeqA ps rest rest' + return $ x == x' && i == i' && q1 && q2 + caseeqA ps (ConstCase x sc : rest) (ConstCase x' sc' : rest') + = do q1 <- caseeq ps sc sc' + q2 <- caseeqA ps rest rest' + return $ x == x' && q1 && q2 + caseeqA ps (DefaultCase sc : rest) (DefaultCase sc' : rest') + = liftM2 (&&) (caseeq ps sc sc') (caseeqA ps rest rest') + caseeqA ps [] [] = return True + caseeqA ps _ _ = return False + caseeq ps (STerm x) (STerm y) = ceq ps x y + caseeq ps (UnmatchedCase _) (UnmatchedCase _) = return True + caseeq ps _ _ = return False + + sameDefs ps x y = case (lookupDef x ctxt, lookupDef y ctxt) of + ([Function _ xdef], [Function _ ydef]) + -> ceq ((x,y):ps) xdef ydef + ([CaseOp _ _ _ _ _ xd], + [CaseOp _ _ _ _ _ yd]) + -> let (_, xdef) = cases_compiletime xd + (_, ydef) = cases_compiletime yd in + caseeq ((x,y):ps) xdef ydef + _ -> return False + +-- SPECIALISATION ----------------------------------------------------------- +-- We need too much control to be able to do this by tweaking the main +-- evaluator + +spec :: Context -> Ctxt [Bool] -> Env -> TT Name -> Eval (TT Name) +spec ctxt statics genv tm = error "spec undefined" + +-- CONTEXTS ----------------------------------------------------------------- + +{-| A definition is either a simple function (just an expression with a type), + a constant, which could be a data or type constructor, an axiom or as an + yet undefined function, or an Operator. + An Operator is a function which explains how to reduce. + A CaseOp is a function defined by a simple case tree -} + +data Def = Function !Type !Term + | TyDecl NameType !Type + | Operator Type Int ([Value] -> Maybe Value) + | CaseOp CaseInfo + !Type + ![Type] -- argument types + ![Either Term (Term, Term)] -- original definition + ![([Name], Term, Term)] -- simplified for totality check definition + !CaseDefs +-- [Name] SC -- Compile time case definition +-- [Name] SC -- Run time cae definitions + +data CaseDefs = CaseDefs { + cases_totcheck :: !([Name], SC), + cases_compiletime :: !([Name], SC), + cases_inlined :: !([Name], SC), + cases_runtime :: !([Name], SC) + } + +data CaseInfo = CaseInfo { + case_inlinable :: Bool, + tc_dictionary :: Bool + } + +{-! +deriving instance Binary Def +!-} +{-! +deriving instance Binary CaseInfo +!-} +{-! +deriving instance Binary CaseDefs +!-} + +instance Show Def where + show (Function ty tm) = "Function: " ++ show (ty, tm) + show (TyDecl nt ty) = "TyDecl: " ++ show nt ++ " " ++ show ty + show (Operator ty _ _) = "Operator: " ++ show ty + show (CaseOp (CaseInfo inlc inlr) ty atys ps_in ps cd) + = let (ns, sc) = cases_compiletime cd + (ns_t, sc_t) = cases_totcheck cd + (ns', sc') = cases_runtime cd in + "Case: " ++ show ty ++ " " ++ show ps ++ "\n" ++ + "TOTALITY CHECK TIME:\n\n" ++ + show ns_t ++ " " ++ show sc_t ++ "\n\n" ++ + "COMPILE TIME:\n\n" ++ + show ns ++ " " ++ show sc ++ "\n\n" ++ + "RUN TIME:\n\n" ++ + show ns' ++ " " ++ show sc' ++ "\n\n" ++ + if inlc then "Inlinable\n" else "Not inlinable\n" + +------- + +-- Frozen => doesn't reduce +-- Hidden => doesn't reduce and invisible to type checker + +data Accessibility = Public | Frozen | Hidden + deriving (Show, Eq) + +-- | The result of totality checking +data Totality = Total [Int] -- ^ well-founded arguments + | Productive -- ^ productive + | Partial PReason + | Unchecked + deriving Eq + +-- | Reasons why a function may not be total +data PReason = Other [Name] | Itself | NotCovering | NotPositive | UseUndef Name + | BelieveMe | Mutual [Name] | NotProductive + deriving (Show, Eq) + +instance Show Totality where + show (Total args)= "Total" -- ++ show args ++ " decreasing arguments" + show Productive = "Productive" -- ++ show args ++ " decreasing arguments" + show Unchecked = "not yet checked for totality" + show (Partial Itself) = "possibly not total as it is not well founded" + show (Partial NotCovering) = "not total as there are missing cases" + show (Partial NotPositive) = "not strictly positive" + show (Partial NotProductive) = "not productive" + show (Partial BelieveMe) = "not total due to use of believe_me in proof" + show (Partial (Other ns)) = "possibly not total due to: " ++ showSep ", " (map show ns) + show (Partial (Mutual ns)) = "possibly not total due to recursive path " ++ + showSep " --> " (map show ns) + +{-! +deriving instance Binary Accessibility +!-} + +{-! +deriving instance Binary Totality +!-} + +{-! +deriving instance Binary PReason +!-} + +-- Possible attached meta-information for a definition in context +data MetaInformation = + EmptyMI -- ^ No meta-information + | DataMI [Int] -- ^ Meta information for a data declaration with position of parameters + deriving (Eq, Show) + +-- | Contexts used for global definitions and for proof state. They contain +-- universe constraints and existing definitions. +data Context = MkContext { + uconstraints :: [UConstraint], + next_tvar :: Int, + definitions :: Ctxt (Def, Accessibility, Totality, MetaInformation) + } deriving Show + +-- | The initial empty context +initContext = MkContext [] 0 emptyContext + +mapDefCtxt :: (Def -> Def) -> Context -> Context +mapDefCtxt f (MkContext c t defs) = MkContext c t (mapCtxt f' defs) + where f' (d, a, t, m) = f' (f d, a, t, m) + +-- | Get the definitions from a context +ctxtAlist :: Context -> [(Name, Def)] +ctxtAlist ctxt = map (\(n, (d, a, t, m)) -> (n, d)) $ toAlist (definitions ctxt) + +veval ctxt env t = evalState (eval False ctxt [] env t []) initEval + +addToCtxt :: Name -> Term -> Type -> Context -> Context +addToCtxt n tm ty uctxt + = let ctxt = definitions uctxt + ctxt' = addDef n (Function ty tm, Public, Unchecked, EmptyMI) ctxt in + uctxt { definitions = ctxt' } + +setAccess :: Name -> Accessibility -> Context -> Context +setAccess n a uctxt + = let ctxt = definitions uctxt + ctxt' = updateDef n (\ (d, _, t, m) -> (d, a, t, m)) ctxt in + uctxt { definitions = ctxt' } + +setTotal :: Name -> Totality -> Context -> Context +setTotal n t uctxt + = let ctxt = definitions uctxt + ctxt' = updateDef n (\ (d, a, _, m) -> (d, a, t, m)) ctxt in + uctxt { definitions = ctxt' } + +setMetaInformation :: Name -> MetaInformation -> Context -> Context +setMetaInformation n m uctxt + = let ctxt = definitions uctxt + ctxt' = updateDef n (\ (d, a, t, _) -> (d, a, t, m)) ctxt in + uctxt { definitions = ctxt' } + +addCtxtDef :: Name -> Def -> Context -> Context +addCtxtDef n d c = let ctxt = definitions c + ctxt' = addDef n (d, Public, Unchecked, EmptyMI) $! ctxt in + c { definitions = ctxt' } + +addTyDecl :: Name -> NameType -> Type -> Context -> Context +addTyDecl n nt ty uctxt + = let ctxt = definitions uctxt + ctxt' = addDef n (TyDecl nt ty, Public, Unchecked, EmptyMI) ctxt in + uctxt { definitions = ctxt' } + +addDatatype :: Datatype Name -> Context -> Context +addDatatype (Data n tag ty cons) uctxt + = let ctxt = definitions uctxt + ty' = normalise uctxt [] ty + ctxt' = addCons 0 cons (addDef n + (TyDecl (TCon tag (arity ty')) ty, Public, Unchecked, EmptyMI) ctxt) in + uctxt { definitions = ctxt' } + where + addCons tag [] ctxt = ctxt + addCons tag ((n, ty) : cons) ctxt + = let ty' = normalise uctxt [] ty in + addCons (tag+1) cons (addDef n + (TyDecl (DCon tag (arity ty')) ty, Public, Unchecked, EmptyMI) ctxt) + +-- FIXME: Too many arguments! Refactor all these Bools. +addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool -> + [Type] -> -- argument types + [Either Term (Term, Term)] -> + [([Name], Term, Term)] -> -- totality + [([Name], Term, Term)] -> -- compile time + [([Name], Term, Term)] -> -- inlined + [([Name], Term, Term)] -> -- run time + Type -> Context -> Context +addCasedef n ci@(CaseInfo alwaysInline tcdict) + tcase covering reflect asserted argtys + ps_in ps_tot ps_inl ps_ct ps_rt ty uctxt + = let ctxt = definitions uctxt + access = case lookupDefAcc n False uctxt of + [(_, acc)] -> acc + _ -> Public + ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC argtys ps_tot, + simpleCase tcase covering reflect CompileTime emptyFC argtys ps_ct, + simpleCase tcase covering reflect CompileTime emptyFC argtys ps_inl, + simpleCase tcase covering reflect RunTime emptyFC argtys ps_rt) of + (OK (CaseDef args_tot sc_tot _), + OK (CaseDef args_ct sc_ct _), + OK (CaseDef args_inl sc_inl _), + OK (CaseDef args_rt sc_rt _)) -> + let inl = alwaysInline -- tcdict + inlc = (inl || small n args_ct sc_ct) && (not asserted) + inlr = inl || small n args_rt sc_rt + cdef = CaseDefs (args_tot, sc_tot) + (args_ct, sc_ct) + (args_inl, sc_inl) + (args_rt, sc_rt) in + addDef n (CaseOp (ci { case_inlinable = inlc }) + ty argtys ps_in ps_tot cdef, + access, Unchecked, EmptyMI) ctxt in + uctxt { definitions = ctxt' } + +-- simplify a definition for totality checking +simplifyCasedef :: Name -> Context -> Context +simplifyCasedef n uctxt + = let ctxt = definitions uctxt + ctxt' = case lookupCtxt n ctxt of + [(CaseOp ci ty atys [] ps _, acc, tot, metainf)] -> + ctxt -- nothing to simplify (or already done...) + [(CaseOp ci ty atys ps_in ps cd, acc, tot, metainf)] -> + let ps_in' = map simpl ps_in + pdef = map debind ps_in' in + case simpleCase False True False CompileTime emptyFC atys pdef of + OK (CaseDef args sc _) -> + addDef n (CaseOp ci + ty atys ps_in' ps (cd { cases_totcheck = (args, sc) }), + acc, tot, metainf) ctxt + Error err -> error (show err) + _ -> ctxt in + uctxt { definitions = ctxt' } + where + depat acc (Bind n (PVar t) sc) + = depat (n : acc) (instantiate (P Bound n t) sc) + depat acc x = (acc, x) + debind (Right (x, y)) = let (vs, x') = depat [] x + (_, y') = depat [] y in + (vs, x', y') + debind (Left x) = let (vs, x') = depat [] x in + (vs, x', Impossible) + simpl (Right (x, y)) = Right (x, simplify uctxt [] y) + simpl t = t + +addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) -> + Context -> Context +addOperator n ty a op uctxt + = let ctxt = definitions uctxt + ctxt' = addDef n (Operator ty a op, Public, Unchecked, EmptyMI) ctxt in + uctxt { definitions = ctxt' } + +tfst (a, _, _, _) = a + +lookupNames :: Name -> Context -> [Name] +lookupNames n ctxt + = let ns = lookupCtxtName n (definitions ctxt) in + map fst ns + +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 :: Name -> Context -> Bool +isConName n ctxt = isTConName n ctxt || isDConName n ctxt + +isTConName :: Name -> Context -> Bool +isTConName n ctxt + = or $ do def <- lookupCtxt n (definitions ctxt) + case tfst def of + (TyDecl (TCon _ _) _) -> return True + _ -> return False + +isDConName :: Name -> Context -> Bool +isDConName n ctxt + = or $ do def <- lookupCtxt n (definitions ctxt) + case tfst def of + (TyDecl (DCon _ _) _) -> return True + _ -> return False + +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 :: 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) + (CaseOp _ ty _ _ _ _, a, _, _) -> return (P Ref n ty, a) + (Operator ty _ _, a, _, _) -> return (P Ref n ty, a) + case snd p of + Hidden -> [] + _ -> return (fst p) + +lookupDef :: Name -> Context -> [Def] +lookupDef n ctxt = map tfst $ lookupCtxt n (definitions ctxt) + +lookupDefAcc :: Name -> Bool -> Context -> + [(Def, Accessibility)] +lookupDefAcc n mkpublic ctxt + = map mkp $ lookupCtxt n (definitions ctxt) + -- io_bind a special case for REPL prettiness + where mkp (d, a, _, _) = if mkpublic && (not (n == sUN "io_bind" || n == sUN "io_return")) + then (d, Public) else (d, a) + +lookupTotal :: Name -> Context -> [Totality] +lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt) + where mkt (d, a, t, m) = t + +lookupMetaInformation :: Name -> Context -> [MetaInformation] +lookupMetaInformation n ctxt = map mkm $ lookupCtxt n (definitions ctxt) + where mkm (d, a, t, m) = m + +lookupNameTotal :: Name -> Context -> [(Name, Totality)] +lookupNameTotal n = map (\(n, (_, _, t, _)) -> (n, t)) . lookupCtxtName n . definitions + + +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)) + +lookupTyEnv :: Name -> Env -> Maybe (Int, Type) +lookupTyEnv n env = li n 0 env where + li n i [] = Nothing + li n i ((x, b): xs) + | n == x = Just (i, binderTy b) + | otherwise = li n (i+1) xs + +-- | Create a unique name given context and other existing names +uniqueNameCtxt :: Context -> Name -> [Name] -> Name +uniqueNameCtxt ctxt n hs + | n `elem` hs = uniqueNameCtxt ctxt (nextName n) hs + | [_] <- lookupTy n ctxt = uniqueNameCtxt ctxt (nextName n) hs + | otherwise = n diff --git a/src/Idris/Core/Execute.hs b/src/Idris/Core/Execute.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Core/Execute.hs @@ -0,0 +1,579 @@ +{-# LANGUAGE PatternGuards, ExistentialQuantification, CPP #-} +module Idris.Core.Execute (execute) where + +import Idris.AbsSyntax +import Idris.AbsSyntaxTree +import IRTS.Lang(FType(..)) + +import Idris.Primitives(Prim(..), primitives) + +import Idris.Core.TT +import Idris.Core.Evaluate +import Idris.Core.CaseTree + +import Debug.Trace + +import Util.DynamicLinker +import Util.System + +import Control.Applicative hiding (Const) +import Control.Exception +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 + +#ifdef IDRIS_FFI +import Foreign.LibFFI +import Foreign.C.String +import Foreign.Marshal.Alloc (free) +import Foreign.Ptr +#endif + +import System.IO + +#ifndef IDRIS_FFI +execute :: Term -> Idris Term +execute tm = fail "libffi not supported, rebuild Idris with -f FFI" +#else +-- else is rest of file +readMay :: (Read a) => String -> Maybe a +readMay s = case reads s of + [(x, "")] -> Just x + _ -> Nothing + +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 ++ " <>" + show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")" + show (EType _) = "Type" + show EErased = "[__]" + show (EConstant c) = show c + show (EPtr p) = "<>" + show (EThunk i) = "<>" + show (EHandle 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 i t) = GHole i <$> 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) (sMN 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 . 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) (sUN "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 _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun + doExec env ctxt tm + [CaseOp _ _ _ _ _ (CaseDefs _ (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) + res <- execApp' env ctxt newF newArgs + return res + where getLaziness (EP _ l _) | l == sUN "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 _ fp _) (ty:action:rest) + | fp == upio, + (prim__IO, [_, v]) <- unApplyV action + = execApp' env ctxt v rest + +execApp' env ctxt (EP _ fp _) args@(_:_:v:k:rest) + | fp == piobind, + (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 _ fp _) args@(tp:v:rest) + | fp == pioret = + 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 _ fp _) (_:fn:EConstant (Str arg):_:rest) + | fp == mkfprim, + Just (FFun "putStr" _ _) <- foreignFromTT fn + = do execIO (putStr arg) + execApp' env ctxt ioUnit rest +execApp' env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest) + | fp == mkfprim, + Just (FFun "idris_readStr" _ _) <- foreignFromTT fn + = do contents <- execIO $ hGetLine h + execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest +execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest) + | fp == mkfprim, + Just (FFun "fileOpen" _ _) <- foreignFromTT fn + = do f <- execIO $ + catch (do let m = case mode of + "r" -> Right ReadMode + "w" -> Right WriteMode + "a" -> Right AppendMode + "rw" -> Right ReadWriteMode + "wr" -> Right ReadWriteMode + "r+" -> Right ReadWriteMode + _ -> Left ("Invalid mode for " ++ f ++ ": " ++ mode) + case fmap (openFile f) m of + Right h -> do h' <- h; return $ Right (ioWrap (EHandle h'), tail rest) + Left err -> return $ Left err) + (\e -> let _ = ( e::SomeException) + in return $ Right (ioWrap (EPtr nullPtr), tail rest)) + case f of + Left err -> execFail err + Right (res, rest) -> execApp' env ctxt res rest + +execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest) + | fp == mkfprim, + 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 (tail rest) + +execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest) + | fp == mkfprim, + Just (FFun "fileClose" _ _) <- foreignFromTT fn + = do execIO $ hClose h + execApp' env ctxt ioUnit (tail rest) + +execApp' env ctxt (EP _ fp _) (_:fn:(EPtr p):rest) + | fp == mkfprim, + Just (FFun "isNull" _ _) <- foreignFromTT fn + = let res = ioWrap . EConstant . I $ + if p == nullPtr then 1 else 0 + in execApp' env ctxt res (tail rest) + +-- Handles will be checked as null pointers sometimes - but if we got a +-- real Handle, then it's valid, so just return 1. +execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest) + | fp == mkfprim, + Just (FFun "isNull" _ _) <- foreignFromTT fn + = let res = ioWrap . EConstant . I $ 0 + in execApp' env ctxt res (tail rest) + +-- A foreign-returned char* has to be tested for NULL sometimes +execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str s):rest) + | fp == mkfprim, + Just (FFun "isNull" _ _) <- foreignFromTT fn + = let res = ioWrap . EConstant . I $ 0 + in execApp' env ctxt res (tail rest) + +-- Throw away the 'World' argument to the foreign function + +execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim + = case foreignFromTT fn of + Just (FFun f argTs retT) | length xs >= length argTs -> + do let (args', xs') = (take (length argTs) xs, -- foreign args + drop (length argTs + 1) xs) -- rest + res <- stepForeign (ty:fn:args') + case res of + Nothing -> fail $ "Could not call foreign function \"" ++ f ++ + "\" with args " ++ show args + Just r -> return (mkEApp r xs') + Nothing -> return (mkEApp f args) + +execApp' env ctxt c@(EP (DCon _ arity) n _) args = + do args' <- mapM tryForce (take arity args) + let restArgs = drop arity args + execApp' env ctxt (mkEApp c args') restArgs + +execApp' env ctxt c@(EP (TCon _ arity) n _) args = + do args' <- mapM tryForce (take arity args) + let restArgs = drop arity args + execApp' env ctxt (mkEApp c args') restArgs + +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 _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun + do rhs <- doExec env ctxt tm + execApp' env ctxt rhs args + [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] -> + do res <- execCase env ctxt ns sc args + return $ fromMaybe (mkEApp f args) res + thing -> return $ mkEApp f args +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) + +prs = sUN "prim__readString" +pbm = sUN "prim__believe_me" +pstd = sUN "prim__stdin" +mkfprim = sUN "mkForeignPrim" +pioret = sUN "prim_io_return" +piobind = sUN "prim_io_bind" +upio = sUN "unsafePerformPrimIO" + +-- | Look up primitive operations in the global table and transform them into ExecVal functions +getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal) +getOp fn [_, _, x] | fn == pbm = Just (return x) +getOp fn [EP _ fn' _] + | fn == prs && fn' == pstd = + Just $ do line <- execIO getLine + return (EConstant (Str line)) +getOp fn [EHandle h] + | fn == prs = + Just $ do contents <- execIO $ hGetLine h + return (EConstant (Str (contents ++ "\n"))) +getOp n args = getPrim n primitives >>= flip applyPrim args + where getPrim :: Name -> [Prim] -> Maybe ([ExecVal] -> Maybe ExecVal) + getPrim n [] = Nothing + getPrim n ((Prim pn _ arity def _ _) : prims) | n == pn = Just $ execPrim def + | otherwise = getPrim n prims + + execPrim :: ([Const] -> Maybe Const) -> [ExecVal] -> Maybe ExecVal + execPrim f args = EConstant <$> (mapM getConst args >>= f) + + getConst (EConstant c) = Just c + getConst _ = Nothing + + applyPrim :: ([ExecVal] -> Maybe ExecVal) -> [ExecVal] -> Maybe (Exec ExecVal) + applyPrim fn args = return <$> fn 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 (FArith ty) = AType ty + 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 + maybe (return Nothing) (\f -> Just . ioWrap <$> call' f args retType) fn + where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal + call' (Fun _ h) args (FArith (ATInt ITNative)) = do + res <- execIO $ callFFI h retCInt (prepArgs args) + return (EConstant (I (fromIntegral res))) + call' (Fun _ h) args (FArith (ATInt (ITFixed IT8))) = do + res <- execIO $ callFFI h retCChar (prepArgs args) + return (EConstant (B8 (fromIntegral res))) + call' (Fun _ h) args (FArith (ATInt (ITFixed IT16))) = do + res <- execIO $ callFFI h retCWchar (prepArgs args) + return (EConstant (B16 (fromIntegral res))) + call' (Fun _ h) args (FArith (ATInt (ITFixed IT32))) = do + res <- execIO $ callFFI h retCInt (prepArgs args) + return (EConstant (B32 (fromIntegral res))) + call' (Fun _ h) args (FArith (ATInt (ITFixed IT64))) = do + res <- execIO $ callFFI h retCLong (prepArgs args) + return (EConstant (B64 (fromIntegral res))) + call' (Fun _ h) args (FArith ATFloat) = do + res <- execIO $ callFFI h retCDouble (prepArgs args) + return (EConstant (Fl (realToFrac res))) + call' (Fun _ h) args (FArith (ATInt ITChar)) = 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) + if res == nullPtr + then return (EPtr res) + else do hStr <- execIO $ peekCString res + return (EConstant (Str hStr)) + + call' (Fun _ h) args FPtr = EPtr <$> (execIO $ callFFI h (retPtr retVoid) (prepArgs args)) + call' (Fun _ h) args FUnit = do _ <- 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 fi) _) (EP _ (UN intTy) _)) + | fi == txt "FIntT" = + case str intTy of + "ITNative" -> Just (FArith (ATInt ITNative)) + "ITChar" -> Just (FArith (ATInt ITChar)) + "IT8" -> Just (FArith (ATInt (ITFixed IT8))) + "IT16" -> Just (FArith (ATInt (ITFixed IT16))) + "IT32" -> Just (FArith (ATInt (ITFixed IT32))) + "IT64" -> Just (FArith (ATInt (ITFixed IT64))) + _ -> Nothing +getFTy (EP _ (UN t) _) = + case str t of + "FFloat" -> Just (FArith ATFloat) + "FString" -> Just FString + "FPtr" -> Just FPtr + "FUnit" -> Just FUnit + _ -> Nothing +getFTy _ = 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) = let ffun = foreignFromTT fn + in case (call <$> ffun) of + Just f -> f args + Nothing -> return Nothing +stepForeign _ = fail "Tried to call foreign function that wasn't mkForeignPrim" + +mapMaybeM :: (Functor m, Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f [] = return [] +mapMaybeM f (x:xs) = do rest <- mapMaybeM f xs + maybe rest (:rest) <$> f x +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) + +#endif diff --git a/src/Idris/Core/ProofState.hs b/src/Idris/Core/ProofState.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Core/ProofState.hs @@ -0,0 +1,889 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-} + +{- Implements a proof state, some primitive tactics for manipulating + proofs, and some high level commands for introducing new theorems, + evaluation/checking inside the proof system, etc. --} + +module Idris.Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus, + Tactic(..), Goal(..), processTactic, + dropGiven, keepGiven) where + +import Idris.Core.Typecheck +import Idris.Core.Evaluate +import Idris.Core.TT +import Idris.Core.Unify + +import Control.Monad.State.Strict +import Control.Applicative hiding (empty) +import Data.List +import Debug.Trace + +import Util.Pretty hiding (fill) + +data ProofState = PS { thname :: Name, + holes :: [Name], -- holes still to be solved + usedns :: [Name], -- used names, don't use again + nextname :: Int, -- name supply + pterm :: Term, -- current proof term + 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], + deferred :: [Name], -- names we'll need to define + instances :: [Name], -- instance arguments (for type classes) + previous :: Maybe ProofState, -- for undo + context :: Context, + plog :: String, + unifylog :: Bool, + done :: Bool + } + +data Goal = GD { premises :: Env, + goalType :: Binder Term + } + +data Tactic = Attack + | Claim Name Raw + | Reorder Name + | Exact Raw + | Fill Raw + | MatchFill Raw + | PrepFill Name [Name] + | CompleteFill + | Regret + | Solve + | StartUnify Name + | EndUnify + | Compute + | ComputeLet Name + | Simplify + | HNF_Compute + | EvalIn Raw + | CheckIn Raw + | Intro (Maybe Name) + | IntroTy Raw (Maybe Name) + | Forall Name Raw + | LetBind Name Raw Raw + | ExpandLet Name Term + | Rewrite Raw + | Induction Name + | Equiv Raw + | PatVar Name + | PatBind Name + | Focus Name + | Defer Name + | DeferType Name Raw [Name] + | Instance Name + | SetInjective Name + | MoveLast Name + | MatchProblems + | UnifyProblems + | ProofState + | Undo + | QED + deriving Show + +-- 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 _ _ _) + = let OK g = goal (Just h) tm + wkenv = premises g in + "Other goals: " ++ show hs ++ "\n" ++ + showPs wkenv (reverse wkenv) ++ "\n" ++ + "-------------------------------- (" ++ show nm ++ + ") -------\n " ++ + show h ++ " : " ++ showG wkenv (goalType g) ++ "\n" + where showPs env [] = "" + showPs env ((n, Let t v):bs) + = " " ++ show n ++ " : " ++ + showEnv env ({- normalise ctxt env -} t) ++ " = " ++ + showEnv env ({- normalise ctxt env -} v) ++ + "\n" ++ showPs env bs + showPs env ((n, b):bs) + = " " ++ show n ++ " : " ++ + showEnv env ({- normalise ctxt env -} (binderTy b)) ++ + "\n" ++ showPs env bs + showG ps (Guess t v) = showEnv ps ({- normalise ctxt ps -} t) ++ + " =?= " ++ showEnv ps v + showG ps b = showEnv ps (binderTy b) + +instance Pretty ProofState OutputAnnotation where + pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _) = + pretty nm <+> colon <+> text " no more goals." + 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 <+> + prettyPs wkEnv (reverse wkEnv) <+> + text "---------- " <+> text "Focussing on" <> colon <+> pretty nm <+> text " ----------" <+> + pretty h <+> colon <+> prettyGoal wkEnv (goalType g) + where + prettyGoal ps (Guess t v) = + prettyEnv ps t <+> text "=?=" <+> prettyEnv ps v + prettyGoal ps b = prettyEnv ps $ binderTy b + + prettyPs env [] = empty + prettyPs env ((n, Let t v):bs) = + nest nestingSize (pretty n <+> colon <+> + prettyEnv env t <+> text "=" <+> prettyEnv env v <+> + nest nestingSize (prettyPs env bs)) + prettyPs env ((n, b):bs) = + nest nestingSize (pretty n <+> colon <+> prettyEnv env (binderTy b) <+> + nest nestingSize (prettyPs env bs)) + +same Nothing n = True +same (Just x) n = x == n + +hole (Hole _) = True +hole (Guess _ _) = True +hole _ = False + +holeName i = sMN i "hole" + +qshow :: Fails -> String +qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs) + +match_unify' :: Context -> Env -> TT Name -> TT Name -> + StateT TState TC [(Name, TT Name)] +match_unify' ctxt env topx topy = + do ps <- get + let dont = dontunify ps + u <- lift $ match_unify ctxt env topx topy dont (holes ps) + let (h, ns) = unified ps + put (ps { unified = (h, u ++ ns) }) + return u + +unify' :: Context -> Env -> TT Name -> TT Name -> + StateT TState TC [(Name, TT Name)] +unify' ctxt env topx topy = + do ps <- get + let dont = dontunify ps + (u, fails) <- traceWhen (unifylog ps) + ("Trying " ++ show (topx, topy) ++ + " in " ++ show env ++ + "\nHoles: " ++ show (holes ps) ++ "\n") $ + lift $ unify ctxt env topx topy dont (holes ps) + let notu = filter (\ (n, t) -> case t of + P _ _ _ -> False + _ -> n `elem` dont) u + traceWhen (unifylog ps) + ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++ + "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails + ++ "\nNot unified:\n" ++ show (notunified ps) + ++ "\nCurrent problems:\n" ++ qshow (problems ps) +-- ++ show (pterm ps) + ++ "\n----------") $ + do ps <- get + let (h, ns) = unified ps + let (ns', probs') = updateProblems (context ps) (u ++ ns) + (fails ++ problems ps) + (injective ps) + (holes ps) + put (ps { problems = probs', + unified = (h, ns'), + notunified = notu ++ notunified ps }) + return u + +getName :: Monad m => String -> StateT TState m Name +getName tag = do ps <- get + let n = nextname ps + put (ps { nextname = n+1 }) + return $ sMN n tag + +action :: Monad m => (ProofState -> ProofState) -> StateT TState m () +action a = do ps <- get + put (a ps) + +addLog :: Monad m => String -> StateT TState m () +addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" }) + +newProof :: Name -> Context -> Type -> ProofState +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, []) [] + Nothing [] [] + [] [] + Nothing ctxt "" False False + +type TState = ProofState -- [TacticAction]) +type RunTactic = Context -> Env -> Term -> StateT TState TC Term +type Hole = Maybe Name -- Nothing = default hole, first in list in proof state + +envAtFocus :: ProofState -> TC Env +envAtFocus ps + | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps) + return (premises g) + | otherwise = fail "No holes" + +goalAtFocus :: ProofState -> TC (Binder Type) +goalAtFocus ps + | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps) + return (goalType g) + | otherwise = Error . Msg $ "No goal in " ++ show (holes ps) ++ show (pterm ps) + +goal :: Hole -> Term -> TC Goal +goal h tm = g [] tm where + g env (Bind n b@(Guess _ _) sc) + | same h n = return $ GD env b + | otherwise + = gb env b `mplus` g ((n, b):env) sc + g env (Bind n b sc) | hole b && same h n = return $ GD env b + | otherwise + = g ((n, b):env) sc `mplus` gb env b + g env (App f a) = g env f `mplus` g env a + g env t = fail "Can't find hole" + + gb env (Let t v) = g env v `mplus` g env t + gb env (Guess t v) = g env v `mplus` g env t + gb env t = g env (binderTy t) + +tactic :: Hole -> RunTactic -> StateT TState TC () +tactic h f = do ps <- get + (tm', _) <- atH (context ps) [] (pterm ps) + ps <- get -- might have changed while processing + put (ps { pterm = tm' }) + where + updated o = do o' <- o + return (o', True) + + ulift2 c env op a b + = do (b', u) <- atH c env b + if u then return (op a b', True) + else do (a', u) <- atH c env a + return (op a' b', u) + + -- Search the things most likely to contain the binding first! + + atH :: Context -> Env -> Term -> StateT TState TC (Term, Bool) + atH c env binder@(Bind n b@(Guess t v) sc) + | same h n = updated (f c env binder) + | otherwise + = do -- binder first + (b', u) <- ulift2 c env Guess t v + if u then return (Bind n b' sc, True) + else do (sc', u) <- atH c ((n, b) : env) sc + return (Bind n b' sc', u) + atH c env binder@(Bind n b sc) + | hole b && same h n = updated (f c env binder) + | otherwise -- scope first + = do (sc', u) <- atH c ((n, b) : env) sc + if u then return (Bind n b sc', True) + else do (b', u) <- atHb c env b + return (Bind n b' sc', u) + atH c env (App f a) = ulift2 c env App f a + atH c env t = return (t, False) + + atHb c env (Let t v) = ulift2 c env Let t v + atHb c env (Guess t v) = ulift2 c env Guess t v + atHb c env t = do (ty', u) <- atH c env (binderTy t) + return (t { binderTy = ty' }, u) + +computeLet :: Context -> Name -> Term -> Term +computeLet ctxt n tm = cl [] tm where + cl env (Bind n' (Let t v) sc) + | n' == n = let v' = normalise ctxt env v in + Bind n' (Let t v') sc + cl env (Bind n' b sc) = Bind n' (fmap (cl env) b) (cl ((n, b):env) sc) + cl env (App f a) = App (cl env f) (cl env a) + cl env t = t + +attack :: RunTactic +attack ctxt env (Bind x (Hole t) sc) + = do h <- getName "hole" + action (\ps -> ps { holes = h : holes ps }) + return $ Bind x (Guess t (newtm h)) sc + where + newtm h = Bind h (Hole t) (P Bound h t) +attack ctxt env _ = fail "Not an attackable hole" + +claim :: Name -> Raw -> RunTactic +claim n ty ctxt env t = + do (tyv, tyt) <- lift $ check ctxt env ty + lift $ isType ctxt env tyt + action (\ps -> let (g:gs) = holes ps in + ps { holes = g : n : gs } ) + return $ Bind n (Hole tyv) t -- (weakenTm 1 t) + +reorder_claims :: RunTactic +reorder_claims ctxt env t + = -- trace (showSep "\n" (map show (scvs t))) $ + let (bs, sc) = scvs t [] + newbs = reverse (sortB (reverse bs)) in + traceWhen (bs /= newbs) (show bs ++ "\n ==> \n" ++ show newbs) $ + return (bindAll newbs sc) + where scvs (Bind n b@(Hole _) sc) acc = scvs sc ((n, b):acc) + scvs sc acc = (reverse acc, sc) + + sortB :: [(Name, Binder (TT Name))] -> [(Name, Binder (TT Name))] + sortB [] = [] + sortB (x:xs) | all (noOcc x) xs = x : sortB xs + | otherwise = sortB (insertB x xs) + + insertB x [] = [x] + insertB x (y:ys) | all (noOcc x) (y:ys) = x : y : ys + | otherwise = y : insertB x ys + + noOcc (n, _) (_, Let t v) = noOccurrence n t && noOccurrence n v + noOcc (n, _) (_, Guess t v) = noOccurrence n t && noOccurrence n v + noOcc (n, _) (_, b) = noOccurrence n (binderTy b) + +focus :: Name -> RunTactic +focus n ctxt env t = do action (\ps -> let hs = holes ps in + if n `elem` hs + then ps { holes = n : (hs \\ [n]) } + else ps) + ps <- get + return t + +movelast :: Name -> RunTactic +movelast n ctxt env t = do action (\ps -> let hs = holes ps in + if n `elem` hs + then ps { holes = (hs \\ [n]) ++ [n] } + else ps) + return t + +instanceArg :: Name -> RunTactic +instanceArg n ctxt env (Bind x (Hole t) sc) + = do action (\ps -> let hs = holes ps + is = instances ps in + ps { holes = (hs \\ [x]) ++ [x], + instances = x:is }) + return (Bind x (Hole t) sc) + +setinj :: Name -> RunTactic +setinj n ctxt env (Bind x (Hole t) sc) + = do action (\ps -> let is = injective ps in + ps { injective = n : is }) + return (Bind x (Hole t) sc) + +defer :: Name -> RunTactic +defer n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' = + do action (\ps -> let hs = holes ps in + ps { holes = hs \\ [x] }) + return (Bind n (GHole (length env) (mkTy (reverse env) t)) + (mkApp (P Ref n ty) (map getP (reverse env)))) + where + mkTy [] t = t + mkTy ((n,b) : bs) t = Bind n (Pi (binderTy b)) (mkTy bs t) + + getP (n, b) = P Bound n (binderTy b) + +-- as defer, but build the type and application explicitly +deferType :: Name -> Raw -> [Name] -> RunTactic +deferType n fty_in args ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' = + do (fty, _) <- lift $ check ctxt env fty_in + action (\ps -> let hs = holes ps + ds = deferred ps in + ps { holes = hs \\ [x], + deferred = n : ds }) + return (Bind n (GHole 0 fty) + (mkApp (P Ref n ty) (map getP args))) + where + getP n = case lookup n env of + Just b -> P Bound n (binderTy b) + Nothing -> error ("deferType can't find " ++ show n) + +regret :: RunTactic +regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc = + do action (\ps -> let hs = holes ps in + ps { holes = hs \\ [x] }) + return sc +regret ctxt env (Bind x (Hole t) _) + = fail $ show x ++ " : " ++ show t ++ " is not solved..." + +exact :: Raw -> RunTactic +exact guess ctxt env (Bind x (Hole ty) sc) = + do (val, valty) <- lift $ check ctxt env guess + lift $ converts ctxt env valty ty + return $ Bind x (Guess ty val) sc +exact _ _ _ _ = fail "Can't fill here." + +-- As exact, but attempts to solve other goals by unification + +fill :: Raw -> RunTactic +fill guess ctxt env (Bind x (Hole ty) sc) = + do (val, valty) <- lift $ check ctxt env guess +-- let valtyn = normalise ctxt env valty +-- let tyn = normalise ctxt env ty + ns <- unify' ctxt env valty ty + ps <- get + let (uh, uns) = unified ps +-- put (ps { unified = (uh, uns ++ ns) }) +-- addLog (show (uh, uns ++ ns)) + return $ Bind x (Guess ty val) sc +fill _ _ _ _ = fail "Can't fill here." + +-- As fill, but attempts to solve other goals by matching + +match_fill :: Raw -> RunTactic +match_fill guess ctxt env (Bind x (Hole ty) sc) = + do (val, valty) <- lift $ check ctxt env guess +-- let valtyn = normalise ctxt env valty +-- let tyn = normalise ctxt env ty + ns <- match_unify' ctxt env valty ty + ps <- get + let (uh, uns) = unified ps +-- put (ps { unified = (uh, uns ++ ns) }) +-- addLog (show (uh, uns ++ ns)) + return $ Bind x (Guess ty val) sc +match_fill _ _ _ _ = fail "Can't fill here." + +prep_fill :: Name -> [Name] -> RunTactic +prep_fill f as ctxt env (Bind x (Hole ty) sc) = + do let val = mkApp (P Ref f Erased) (map (\n -> P Ref n Erased) as) + return $ Bind x (Guess ty val) sc +prep_fill f as ctxt env t = fail $ "Can't prepare fill at " ++ show t + +complete_fill :: RunTactic +complete_fill ctxt env (Bind x (Guess ty val) sc) = + do let guess = forget val + (val', valty) <- lift $ check ctxt env guess + ns <- unify' ctxt env valty ty + ps <- get + let (uh, uns) = unified ps +-- put (ps { unified = (uh, uns ++ ns) }) + 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 -> unify' ctxt env tm val + _ -> return [] + action (\ps -> ps { holes = holes ps \\ [x], + solved = Just (x, val), + instances = instances ps \\ [x] }) + let tm' = subst x val sc in + return tm' + | otherwise = lift $ tfail $ IncompleteTerm val +solve _ _ h@(Bind x t sc) + = do ps <- get + case findType x sc of + Just t -> lift $ tfail (CantInferType (show t)) + _ -> fail $ "Not a guess " ++ show h ++ "\n" ++ show (holes ps, pterm ps) + where findType x (Bind n (Let t v) sc) + = findType x v `mplus` findType x sc + findType x (Bind n t sc) + | P _ x' _ <- binderTy t, x == x' = Just n + | otherwise = findType x sc + findType x _ = Nothing + +introTy :: Raw -> Maybe Name -> RunTactic +introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = + do let n = case mn of + Just name -> name + Nothing -> x + let t' = case t of + x@(Bind y (Pi s) _) -> x + _ -> hnf ctxt env t + (tyv, tyt) <- lift $ check ctxt env ty +-- ns <- lift $ unify ctxt env tyv t' + case t' of + Bind y (Pi s) t -> let t' = subst y (P Bound n s) t in + do ns <- unify' ctxt env s tyv + ps <- get + let (uh, uns) = unified ps +-- put (ps { unified = (uh, uns ++ ns) }) + return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t')) + _ -> lift $ tfail $ CantIntroduce t' +introTy ty n ctxt env _ = fail "Can't introduce here." + +intro :: Maybe Name -> RunTactic +intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = + do let n = case mn of + Just name -> name + Nothing -> x + let t' = case t of + x@(Bind y (Pi s) _) -> x + _ -> hnf ctxt env t + case t' of + Bind y (Pi s) t -> -- trace ("in type " ++ show t') $ + let t' = subst y (P Bound n s) t in + return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t')) + _ -> 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 + unify' ctxt env tyt (TType (UVar 0)) + unify' ctxt env t (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" + +patvar :: Name -> RunTactic +patvar n ctxt env (Bind x (Hole t) sc) = + do action (\ps -> ps { holes = holes ps \\ [x] }) + return $ Bind n (PVar t) (subst x (P Bound n t) sc) +patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm + +letbind :: Name -> Raw -> Raw -> RunTactic +letbind n ty val ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = + do (tyv, tyt) <- lift $ check ctxt env ty + (valv, valt) <- lift $ check ctxt env val + lift $ isType ctxt env tyt + return $ Bind n (Let tyv valv) (Bind x (Hole t) (P Bound x t)) +letbind n ty val ctxt env _ = fail "Can't let bind here" + +expandLet :: Name -> Term -> RunTactic +expandLet n v ctxt env tm = + return $ subst n v tm + +rewrite :: Raw -> RunTactic +rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' = + do (tmv, tmt) <- lift $ check ctxt env tm + let tmt' = normalise ctxt env tmt + case unApply tmt' of + (P _ (UN q) _, [lt,rt,l,r]) | q == txt "=" -> + do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t) + let newt = mkP l r l t + let sc = forget $ (Bind x (Hole newt) + (mkApp (P Ref (sUN "replace") (TType (UVal 0))) + [lt, l, r, p, tmv, xp])) + (scv, sct) <- lift $ check ctxt env sc + return scv + _ -> lift $ tfail (NotEquality tmv tmt') + where rname = sMN 0 "replaced" +rewrite _ _ _ _ = fail "Can't rewrite here" + +-- To make the P for rewrite, replace syntactic occurrences of l in ty with +-- an x, and put \x : lt in front +mkP :: TT Name -> TT Name -> TT Name -> TT Name -> TT Name +mkP lt l r ty | l == ty = lt +mkP lt l r (App f a) = let f' = if (r /= f) then mkP lt l r f else f + a' = if (r /= a) then mkP lt l r a else a in + App f' a' +mkP lt l r (Bind n b sc) + = let b' = mkPB b + sc' = if (r /= sc) then mkP lt l r sc else sc in + Bind n b' sc' + where mkPB (Let t v) = let t' = if (r /= t) then mkP lt l r t else t + v' = if (r /= v) then mkP lt l r v else v in + Let t' v' + mkPB b = let ty = binderTy b + ty' = if (r /= ty) then mkP lt l r ty else ty in + b { binderTy = ty' } +mkP lt l r x = x + +induction :: Name -> RunTactic +induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do + (tmv, tmt) <- lift $ check ctxt env (Var nm) + let tmt' = normalise ctxt env tmt + case unApply tmt' of + (P _ tnm _, tyargs) -> do + case lookupTy (SN (ElimN tnm)) ctxt of + [elimTy] -> do + param_pos <- case lookupMetaInformation tnm ctxt of + [DataMI param_pos] -> return param_pos + m | length tyargs > 0 -> fail $ "Invalid meta information for " ++ show tnm ++ " where the metainformation is " ++ show m ++ " and definition is" ++ show (lookupDef tnm ctxt) + _ -> return [] + let (params, indicies) = splitTyArgs param_pos tyargs + let args = getArgTys elimTy + let pmargs = take (length params) args + let args' = drop (length params) args + let propTy = head args' + let restargs = init $ tail args' + let consargs = take (length restargs - length indicies) $ restargs + let indxargs = drop (length restargs - length indicies) $ restargs + let scr = last $ tail args' + let indxnames = makeIndexNames indicies + prop <- replaceIndicies indxnames indicies $ Bind nm (Lam tmt') t + let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs (mkApp (P Ref (SN (ElimN tnm)) (TType (UVal 0))) + (params ++ [prop] ++ map makeConsArg consargs ++ indicies ++ [tmv]))) + action (\ps -> ps {holes = holes ps \\ [x]}) + mapM_ addConsHole (reverse consargs) + let res' = forget $ res + (scv, sct) <- lift $ check ctxt env res' + let scv' = specialise ctxt env [] scv + return scv' + [] -> fail $ "Induction needs an eliminator for " ++ show tnm + xs -> fail $ "Multiple definitions found when searching for the eliminator of " ++ show tnm + _ -> fail "Unkown type for induction" + where scname = sMN 0 "scarg" + makeConsArg (nm, ty) = P Bound nm ty + bindConsArgs ((nm, ty):args) v = Bind nm (Hole ty) $ bindConsArgs args v + bindConsArgs [] v = v + addConsHole (nm, ty) = + action (\ps -> ps { holes = nm : holes ps }) + splitTyArgs param_pos tyargs = + let (params, indicies) = partition (flip elem param_pos . fst) . zip [0..] $ tyargs + in (map snd params, map snd indicies) + makeIndexNames = foldr (\_ nms -> (uniqueNameCtxt ctxt (sMN 0 "idx") nms):nms) [] + replaceIndicies idnms idxs prop = foldM (\t (idnm, idx) -> do (idxv, idxt) <- lift $ check ctxt env (forget idx) + let var = P Bound idnm idxt + return $ Bind idnm (Lam idxt) (mkP var idxv var t)) prop $ zip idnms idxs +induction tm ctxt env _ = do fail "Can't do induction here" + + +equiv :: Raw -> RunTactic +equiv tm ctxt env (Bind x (Hole t) sc) = + do (tmv, tmt) <- lift $ check ctxt env tm + lift $ converts ctxt env tmv t + return $ Bind x (Hole tmv) sc +equiv tm ctxt env _ = fail "Can't equiv here" + +patbind :: Name -> RunTactic +patbind n ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = + do let t' = case t of + x@(Bind y (PVTy s) t) -> x + _ -> hnf ctxt env t + case t' of + Bind y (PVTy s) t -> let t' = subst y (P Bound n s) t in + return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t')) + _ -> fail "Nothing to pattern bind" +patbind n ctxt env _ = fail "Can't pattern bind here" + +compute :: RunTactic +compute ctxt env (Bind x (Hole ty) sc) = + do return $ Bind x (Hole (normalise ctxt env ty)) sc +compute ctxt env t = return t + +hnf_compute :: RunTactic +hnf_compute ctxt env (Bind x (Hole ty) sc) = + do let ty' = hnf ctxt env ty in +-- trace ("HNF " ++ show (ty, ty')) $ + return $ Bind x (Hole ty') sc +hnf_compute ctxt env t = return t + +-- reduce let bindings only +simplify :: RunTactic +simplify ctxt env (Bind x (Hole ty) sc) = + do return $ Bind x (Hole (specialise ctxt env [] ty)) sc +simplify ctxt env t = return t + +check_in :: Raw -> RunTactic +check_in t ctxt env tm = + do (val, valty) <- lift $ check ctxt env t + addLog (showEnv env val ++ " : " ++ showEnv env valty) + return tm + +eval_in :: Raw -> RunTactic +eval_in t ctxt env tm = + do (val, valty) <- lift $ check ctxt env t + let val' = normalise ctxt env val + let valty' = normalise ctxt env valty + addLog (showEnv env val ++ " : " ++ + showEnv env valty ++ +-- " in " ++ show env ++ + " ==>\n " ++ + showEnv env val' ++ " : " ++ + showEnv env valty') + return tm + +start_unify :: Name -> RunTactic +start_unify n ctxt env tm = do -- action (\ps -> ps { unified = (n, []) }) + return tm + +tmap f (a, b, c) = (f a, b, c) + +solve_unified :: RunTactic +solve_unified ctxt env tm = + do ps <- get + let (_, ns) = unified ps + let unify = dropGiven (dontunify ps) ns (holes ps) + action (\ps -> ps { holes = holes ps \\ map fst unify }) + action (\ps -> ps { pterm = updateSolved unify (pterm ps) }) + return (updateSolved unify tm) + where + +dropGiven du [] hs = [] +dropGiven du ((n, P Bound t ty) : us) hs + | n `elem` du && not (t `elem` du) + && n `elem` hs && t `elem` hs + = (t, P Bound n ty) : dropGiven du us hs +dropGiven du (u@(n, _) : us) hs + | n `elem` du = dropGiven du us hs +-- 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 = updateSolved' xs x +updateSolved' [] x = x +updateSolved' xs (Bind n (Hole ty) t) + | Just v <- lookup n xs + = case xs of + [_] -> psubst n v t + _ -> psubst n v (updateSolved' xs t) +updateSolved' xs (Bind n b t) + | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t) +updateSolved' xs (App f a) + = App (updateSolved' xs f) (updateSolved' xs a) +updateSolved' xs (P _ n@(MN _ _) _) + | Just v <- lookup n xs = v +updateSolved' xs t = t + +updateEnv [] e = e +updateEnv ns [] = [] +updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env + +updateError [] err = err +updateError ns (CantUnify b l r e xs sc) + = CantUnify b (updateSolved ns l) (updateSolved ns r) (updateError ns e) xs sc +updateError ns e = e + +solveInProblems x val [] = [] +solveInProblems x val ((l, r, env, err) : ps) + = ((psubst x val l, psubst x val r, + updateEnv [(x, val)] env, err) : solveInProblems x val ps) + +updateNotunified [] nu = nu +updateNotunified ns nu = up nu where + up [] = [] + up ((n, t) : nus) = let t' = updateSolved ns t in + ((n, t') : up nus) + +updateProblems ctxt [] ps inj holes = ([], ps) +updateProblems ctxt ns ps inj holes = up ns ps where + up ns [] = (ns, []) + up ns ((x, y, env, err) : ps) = + let x' = updateSolved ns x + y' = updateSolved ns y + err' = updateError ns err + env' = updateEnv ns env in + case unify ctxt env' x' y' inj holes of + OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $ + up (ns ++ v) ps + _ -> let (ns', ps') = up ns ps in + (ns', (x',y',env',err') : ps') + +-- attempt to solve remaining problems with match_unify +matchProblems ctxt ps inj holes = up [] ps where + up ns [] = (ns, []) + up ns ((x, y, env, err) : ps) = + let x' = updateSolved ns x + y' = updateSolved ns y + err' = updateError ns err + env' = updateEnv ns env in + case match_unify ctxt env' x' y' inj holes of + OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $ + up (ns ++ v) ps + _ -> let (ns', ps') = up ns ps in + (ns', (x',y',env',err') : ps') + +processTactic :: Tactic -> ProofState -> TC (ProofState, String) +processTactic QED ps = case holes ps of + [] -> do let tm = {- normalise (context ps) [] -} (pterm ps) + (tm', ty', _) <- recheck (context ps) [] (forget tm) tm + return (ps { done = True, pterm = tm' }, + "Proof complete: " ++ showEnv [] tm') + _ -> fail "Still holes to fill." +processTactic ProofState ps = return (ps, showEnv [] (pterm ps)) +processTactic Undo ps = case previous ps of + Nothing -> fail "Nothing to undo." + Just pold -> return (pold, "") +processTactic EndUnify ps + = let (h, ns_in) = unified ps + ns = dropGiven (dontunify ps) ns_in (holes ps) + ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns + (ns'', probs') = updateProblems (context ps) ns' (problems ps) + (injective ps) (holes ps) + tm' = updateSolved ns'' (pterm ps) in + return (ps { pterm = tm', + unified = (h, []), + problems = probs', + notunified = updateNotunified ns'' (notunified ps), + holes = holes ps \\ map fst ns'' }, "") +processTactic (Reorder n) ps + = do ps' <- execStateT (tactic (Just n) reorder_claims) ps + return (ps' { previous = Just ps, plog = "" }, plog ps') +processTactic (ComputeLet n) ps + = return (ps { pterm = computeLet (context ps) n (pterm ps) }, "") +processTactic UnifyProblems ps + = let (ns', probs') = updateProblems (context ps) [] + (problems ps) + (injective ps) + (holes ps) + pterm' = updateSolved ns' (pterm ps) in + return (ps { pterm = pterm', solved = Nothing, problems = probs', + previous = Just ps, plog = "", + notunified = updateNotunified ns' (notunified ps), + holes = holes ps \\ (map fst ns') }, plog ps) +processTactic MatchProblems ps + = let (ns', probs') = matchProblems (context ps) + (problems ps) + (injective ps) + (holes ps) + pterm' = updateSolved ns' (pterm ps) in + return (ps { pterm = pterm', solved = Nothing, problems = probs', + previous = Just ps, plog = "", + notunified = updateNotunified ns' (notunified ps), + holes = holes ps \\ (map fst ns') }, plog ps) +processTactic t ps + = case holes ps of + [] -> fail "Nothing to fill in." + (h:_) -> do ps' <- execStateT (process t h) ps + let (ns', probs') + = case solved ps' of + Just s -> updateProblems (context ps') + [s] (problems ps') + (injective ps') + (holes ps') + _ -> ([], problems ps') + -- rechecking problems may find more solutions, so + -- apply them here + let pterm'' = updateSolved ns' (pterm ps') + return (ps' { pterm = pterm'', + solved = Nothing, + problems = probs', + notunified = updateNotunified ns' (notunified ps'), + previous = Just ps, plog = "", + holes = holes ps' \\ (map fst ns')}, plog ps') + +process :: Tactic -> Name -> StateT TState TC () +process EndUnify _ + = do ps <- get + let (h, _) = unified ps + tactic (Just h) solve_unified +process t h = tactic (Just h) (mktac t) + where mktac Attack = attack + mktac (Claim n r) = claim n r + mktac (Exact r) = exact r + mktac (Fill r) = fill r + mktac (MatchFill r) = match_fill r + mktac (PrepFill n ns) = prep_fill n ns + mktac CompleteFill = complete_fill + mktac Regret = regret + mktac Solve = solve + mktac (StartUnify n) = start_unify n + mktac Compute = compute + mktac Simplify = Idris.Core.ProofState.simplify + mktac HNF_Compute = hnf_compute + mktac (Intro n) = intro n + mktac (IntroTy ty n) = introTy ty n + mktac (Forall n t) = forall n t + mktac (LetBind n t v) = letbind n t v + mktac (ExpandLet n b) = expandLet n b + mktac (Rewrite t) = rewrite t + mktac (Induction t) = induction t + mktac (Equiv t) = equiv t + mktac (PatVar n) = patvar n + mktac (PatBind n) = patbind n + mktac (CheckIn r) = check_in r + mktac (EvalIn r) = eval_in r + mktac (Focus n) = focus n + mktac (Defer n) = defer n + mktac (DeferType n t a) = deferType n t a + mktac (Instance n) = instanceArg n + mktac (SetInjective n) = setinj n + mktac (MoveLast n) = movelast n diff --git a/src/Idris/Core/TC.hs b/src/Idris/Core/TC.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Core/TC.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveFunctor #-} + +module Idris.Core.TC(TC'(..)) where + +import Control.Monad +import Control.Monad.Trans.Error(Error(..)) + +data TC' e a = OK !a + | Error e + deriving (Eq, Functor) + +bindTC :: TC' e a -> (a -> TC' e b) -> TC' e b +bindTC x k = case x of + OK v -> k v + Error e -> Error e +{-# INLINE bindTC #-} + +instance Error e => Monad (TC' e) where + return x = OK x + x >>= k = bindTC x k + fail e = Error (strMsg e) + +instance Error e => MonadPlus (TC' e) where + mzero = fail "Unknown error" + (OK x) `mplus` _ = OK x + _ `mplus` (OK y) = OK y + err `mplus` _ = err + diff --git a/src/Idris/Core/TT.hs b/src/Idris/Core/TT.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Core/TT.hs @@ -0,0 +1,1205 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor #-} + +{-| TT is the core language of Idris. The language has: + + * Full dependent types + + * A hierarchy of universes, with cumulativity: Type : Type1, Type1 : Type2, ... + + * Pattern matching letrec binding + + * (primitive types defined externally) + + Some technical stuff: + + * Typechecker is kept as simple as possible - no unification, just a checker for incomplete terms. + + * We have a simple collection of tactics which we use to elaborate source + programs with implicit syntax into fully explicit terms. +-} + +module Idris.Core.TT(module Idris.Core.TT, module Idris.Core.TC) where + +import Idris.Core.TC + +import Control.Monad.State.Strict +import Control.Monad.Trans.Error (Error(..)) +import Debug.Trace +import qualified Data.Map.Strict as Map +import Data.Char +import qualified Data.Text as T +import Data.List +import Data.Maybe (listToMaybe) +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as V +import qualified Data.Binary as B +import Data.Binary hiding (get, put) +import Foreign.Storable (sizeOf) + +import Util.Pretty hiding (Str) + +data Option = TTypeInTType + | CheckConv + deriving Eq + +-- | Source location. These are typically produced by the parser 'Idris.Parser.getFC' +data FC = FC { fc_fname :: String, -- ^ Filename + fc_line :: Int, -- ^ Line number + fc_column :: Int -- ^ Column number + } + +-- | Ignore source location equality (so deriving classes do not compare FCs) +instance Eq FC where + _ == _ = True + +-- | FC with equality +newtype FC' = FC' { unwrapFC :: FC } + +instance Eq FC' where + FC' fc == FC' fc' = fcEq fc fc' + where fcEq (FC n l c) (FC n' l' c') = n == n' && l == l' && c == c' + +-- | Empty source location +emptyFC :: FC +emptyFC = fileFC "" + +-- | Source location with file only +fileFC :: String -> FC +fileFC s = FC s 0 0 + +{-! +deriving instance Binary FC +deriving instance NFData FC +!-} + +instance Sized FC where + size (FC f l c) = 1 + length f + +instance Show FC where + show (FC f l c) = f ++ ":" ++ show l ++ ":" ++ show c + +-- | Output annotation for pretty-printed name - decides colour +data NameOutput = TypeOutput | FunOutput | DataOutput + +-- | Output annotations for pretty-printing +data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe Type) + | AnnBoundName Name Bool + | AnnConstData + | AnnConstType + | AnnFC FC + +-- | Used for error reflection +data ErrorReportPart = TextPart String + | NamePart Name + | TermPart Term + | SubReport [ErrorReportPart] + deriving (Show, Eq) + + +-- Please remember to keep Err synchronised with +-- Language.Reflection.Errors.Err in the stdlib! + +-- | Idris errors. Used as exceptions in the compiler, but reported to users +-- if they reach the top level. +data Err' t + = Msg String + | InternalMsg String + | CantUnify Bool t t (Err' t) [(Name, t)] Int + -- Int is 'score' - how much we did unify + -- Bool indicates recoverability, True indicates more info may make + -- unification succeed + | InfiniteUnify Name t [(Name, t)] + | CantConvert t t [(Name, t)] + | CantSolveGoal t [(Name, t)] + | UnifyScope Name Name t [(Name, t)] + | CantInferType String + | NonFunctionType t t + | NotEquality t t + | TooManyArguments Name + | CantIntroduce t + | NoSuchVariable Name + | NoTypeDecl Name + | NotInjective t t t + | CantResolve t + | CantResolveAlts [String] + | IncompleteTerm t + | UniverseError + | ProgramLineComment + | Inaccessible Name + | NonCollapsiblePostulate Name + | AlreadyDefined Name + | ProofSearchFail (Err' t) + | NoRewriting t + | At FC (Err' t) + | Elaborating String Name (Err' t) + | ProviderError String + | LoadingFailed String (Err' t) + | ReflectionError [[ErrorReportPart]] (Err' t) + | ReflectionFailed String (Err' t) + deriving (Eq, Functor) + +type Err = Err' Term + +{-! +deriving instance NFData Err +!-} + +instance Sized Err where + size (Msg msg) = length msg + size (InternalMsg msg) = length msg + size (CantUnify _ left right err _ score) = size left + size right + size err + size (InfiniteUnify _ right _) = size right + size (CantConvert left right _) = size left + size right + size (UnifyScope _ _ right _) = size right + size (NoSuchVariable name) = size name + 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 (Elaborating _ n err) = size err + size (ProviderError msg) = length msg + size (LoadingFailed fn e) = 1 + length fn + size e + size _ = 1 + +score :: Err -> Int +score (CantUnify _ _ _ m _ s) = s + score m +score (CantResolve _) = 20 +score (NoSuchVariable _) = 1000 +score (ProofSearchFail _) = 10000 +score (CantSolveGoal _ _) = 10000 +score (InternalMsg _) = -1 +score _ = 0 + +instance Show Err where + show (Msg s) = s + show (InternalMsg s) = "Internal error: " ++ show s + show (CantUnify _ l r e sc i) = "CantUnify " ++ show l ++ " " ++ show r ++ " " + ++ show e ++ " in " ++ show sc ++ " " ++ show i + show (CantSolveGoal g _) = "CantSolve " ++ show g + show (Inaccessible n) = show n ++ " is not an accessible pattern variable" + show (ProviderError msg) = "Type provider error: " ++ msg + show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: (TT) " ++ show e + show ProgramLineComment = "Program line next to comment" + show (At f e) = show f ++ ":" ++ show e + show _ = "Error" + +instance Pretty Err OutputAnnotation where + pretty (Msg m) = text m + pretty (CantUnify _ l r e _ i) = + 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 err@(LoadingFailed _ _) = text (show err) + pretty _ = text "Error" + +instance Error Err where + strMsg = InternalMsg + +type TC = TC' Err + +instance (Pretty a OutputAnnotation) => Pretty (TC a) OutputAnnotation where + pretty (OK ok) = pretty ok + pretty (Error err) = + text "Error" <+> colon <+> pretty err + +instance Show a => Show (TC a) where + show (OK x) = show x + show (Error str) = "Error: " ++ show str + +tfail :: Err -> TC a +tfail e = Error e + +failMsg :: String -> TC a +failMsg str = Error (Msg str) + +trun :: FC -> TC a -> TC a +trun fc (OK a) = OK a +trun fc (Error e) = Error (At fc e) + +discard :: Monad m => m a -> m () +discard f = f >> return () + +showSep :: String -> [String] -> String +showSep sep [] = "" +showSep sep [x] = x +showSep sep (x:xs) = x ++ sep ++ showSep sep xs + +pmap f (x, y) = (f x, f y) + +traceWhen True msg a = trace msg a +traceWhen False _ a = a + +-- RAW TERMS ---------------------------------------------------------------- + +-- | Names are hierarchies of strings, describing scope (so no danger of +-- duplicate names, but need to be careful on lookup). +data Name = UN T.Text -- ^ User-provided name + | NS Name [T.Text] -- ^ Root, namespaces + | MN Int T.Text -- ^ Machine chosen names + | NErased -- ^ Name of somethng which is never used in scope + | SN SpecialName -- ^ Decorated function names + | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation) + deriving (Eq, Ord) + +txt :: String -> T.Text +txt = T.pack + +str :: T.Text -> String +str = T.unpack + +tnull :: T.Text -> Bool +tnull = T.null + +thead :: T.Text -> Char +thead = T.head + +-- Smart constructors for names, using old String style +sUN :: String -> Name +sUN s = UN (txt s) + +sNS :: Name -> [String] -> Name +sNS n ss = NS n (map txt ss) + +sMN :: Int -> String -> Name +sMN i s = MN i (txt s) + +{-! +deriving instance Binary Name +deriving instance NFData Name +!-} + +data SpecialName = WhereN Int Name Name + | InstanceN Name [T.Text] + | ParentN Name T.Text + | MethodN Name + | CaseN Name + | ElimN Name + deriving (Eq, Ord) +{-! +deriving instance Binary SpecialName +deriving instance NFData SpecialName +!-} + +sInstanceN :: Name -> [String] -> SpecialName +sInstanceN n ss = InstanceN n (map T.pack ss) + +sParentN :: Name -> String -> SpecialName +sParentN n s = ParentN n (T.pack s) + +instance Sized Name where + size (UN n) = 1 + size (NS n els) = 1 + length els + size (MN i n) = 1 + size _ = 1 + +instance Pretty Name OutputAnnotation where + pretty n@(UN n') = annotate (AnnName n Nothing Nothing) $ text (T.unpack n') + pretty n@(NS un s) = annotate (AnnName n Nothing Nothing) . noAnnotate $ pretty un + pretty n@(MN i s) = annotate (AnnName n Nothing Nothing) $ + lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace + pretty n@(SN s) = annotate (AnnName n Nothing Nothing) $ text (show s) + +instance Pretty [Name] OutputAnnotation where + pretty = encloseSep empty empty comma . map pretty + +instance Show Name where + show (UN n) = str n + show (NS n s) = showSep "." (map T.unpack (reverse s)) ++ "." ++ show n + show (MN _ u) | u == txt "underscore" = "_" + show (MN i s) = "{" ++ str s ++ show i ++ "}" + show (SN s) = show s + show NErased = "_" + +instance Show SpecialName where + show (WhereN i p c) = show p ++ ", " ++ show c + show (InstanceN cl inst) = showSep ", " (map T.unpack inst) ++ " instance of " ++ show cl + show (MethodN m) = "method " ++ show m + show (ParentN p c) = show p ++ "#" ++ T.unpack c + show (CaseN n) = "case block in " ++ show n + show (ElimN n) = "<<" ++ show n ++ " eliminator>>" + +-- Show a name in a way decorated for code generation, not human reading +showCG :: Name -> String +showCG (UN n) = T.unpack n +showCG (NS n s) = showSep "." (map T.unpack (reverse s)) ++ "." ++ showCG n +showCG (MN _ u) | u == txt "underscore" = "_" +showCG (MN i s) = "{" ++ T.unpack s ++ show i ++ "}" +showCG (SN s) = showCG' s + where showCG' (WhereN i p c) = showCG p ++ ":" ++ showCG c ++ ":" ++ show i + showCG' (InstanceN cl inst) = '@':showCG cl ++ '$':showSep ":" (map T.unpack inst) + showCG' (MethodN m) = '!':showCG m + showCG' (ParentN p c) = showCG p ++ "#" ++ show c + showCG' (CaseN c) = showCG c ++ "_case" + showCG' (ElimN sn) = showCG sn ++ "_elim" +showCG NErased = "_" + + +-- |Contexts allow us to map names to things. A root name maps to a collection +-- of things in different namespaces with that name. +type Ctxt a = Map.Map Name (Map.Map Name a) +emptyContext = Map.empty + +mapCtxt :: (a -> b) -> Ctxt a -> Ctxt b +mapCtxt = fmap . fmap + +-- |Return True if the argument 'Name' should be interpreted as the name of a +-- typeclass. +tcname (UN xs) | T.null xs = False + | otherwise = T.head xs == '@' +tcname (NS n _) = tcname n +tcname (SN (InstanceN _ _)) = True +tcname (SN (MethodN _)) = True +tcname (SN (ParentN _ _)) = True +tcname _ = False + +implicitable (NS n _) = implicitable n +implicitable (UN xs) | T.null xs = False + | otherwise = isLower (T.head xs) +implicitable (MN _ _) = True +implicitable _ = False + +nsroot (NS n _) = n +nsroot n = n + +addDef :: Name -> a -> Ctxt a -> Ctxt a +addDef n v ctxt = case Map.lookup (nsroot n) ctxt of + Nothing -> Map.insert (nsroot n) + (Map.insert n v Map.empty) ctxt + Just xs -> Map.insert (nsroot n) + (Map.insert n v xs) ctxt + +{-| Look up a name in the context, given an optional namespace. + The name (n) may itself have a (partial) namespace given. + + Rules for resolution: + + - if an explicit namespace is given, return the names which match it. If none + match, return all names. + + - if the name has has explicit namespace given, return the names which match it + and ignore the given namespace. + + - otherwise, return all names. + +-} + +lookupCtxtName :: Name -> Ctxt a -> [(Name, a)] +lookupCtxtName n ctxt = case Map.lookup (nsroot n) ctxt of + Just xs -> filterNS (Map.toList xs) + Nothing -> [] + where + filterNS [] = [] + filterNS ((found, v) : xs) + | nsmatch n found = (found, v) : filterNS xs + | otherwise = filterNS xs + + nsmatch (NS n ns) (NS p ps) = ns `isPrefixOf` ps + nsmatch (NS _ _) _ = False + nsmatch looking found = True + +lookupCtxt :: Name -> Ctxt a -> [a] +lookupCtxt n ctxt = map snd (lookupCtxtName n ctxt) + +lookupCtxtExact :: Name -> Ctxt a -> Maybe a +lookupCtxtExact n ctxt = listToMaybe [ v | (nm, v) <- lookupCtxtName n ctxt, nm == n] + +updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a +updateDef n f ctxt + = let ds = lookupCtxtName n ctxt in + foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds + +toAlist :: Ctxt a -> [(Name, a)] +toAlist ctxt = let allns = map snd (Map.toList ctxt) in + concat (map (Map.toList) allns) + +addAlist :: Show a => [(Name, a)] -> Ctxt a -> Ctxt a +addAlist [] ctxt = ctxt +addAlist ((n, tm) : ds) ctxt = addDef n tm (addAlist ds ctxt) + +data NativeTy = IT8 | IT16 | IT32 | IT64 + deriving (Show, Eq, Ord, Enum) + +instance Pretty NativeTy OutputAnnotation where + pretty IT8 = text "Bits8" + pretty IT16 = text "Bits16" + pretty IT32 = text "Bits32" + pretty IT64 = text "Bits64" + +data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar + | ITVec NativeTy Int + deriving (Show, Eq, Ord) + +intTyName :: IntTy -> String +intTyName ITNative = "Int" +intTyName ITBig = "BigInt" +intTyName (ITFixed sized) = "B" ++ show (nativeTyWidth sized) +intTyName (ITChar) = "Char" +intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show count + +data ArithTy = ATInt IntTy | ATFloat -- TODO: Float vectors + deriving (Show, Eq, Ord) +{-! +deriving instance NFData IntTy +deriving instance NFData NativeTy +deriving instance NFData ArithTy +!-} + +instance Pretty ArithTy OutputAnnotation where + pretty (ATInt ITNative) = text "Int" + pretty (ATInt ITBig) = text "BigInt" + pretty (ATInt ITChar) = text "Char" + pretty (ATInt (ITFixed n)) = pretty n + pretty (ATInt (ITVec e c)) = pretty e <> text "x" <> (text . show $ c) + pretty ATFloat = text "Float" + +nativeTyWidth :: NativeTy -> Int +nativeTyWidth IT8 = 8 +nativeTyWidth IT16 = 16 +nativeTyWidth IT32 = 32 +nativeTyWidth IT64 = 64 + +{-# DEPRECATED intTyWidth "Non-total function, use nativeTyWidth and appropriate casing" #-} +intTyWidth :: IntTy -> Int +intTyWidth (ITFixed n) = nativeTyWidth n +intTyWidth ITNative = 8 * sizeOf (0 :: Int) +intTyWidth ITChar = error "IRTS.Lang.intTyWidth: Characters have platform and backend dependent width" +intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width" + +data Const = I Int | BI Integer | Fl Double | Ch Char | Str String + | B8 Word8 | B16 Word16 | B32 Word32 | B64 Word64 + | B8V (Vector Word8) | B16V (Vector Word16) + | B32V (Vector Word32) | B64V (Vector Word64) + | AType ArithTy | StrType + | PtrType | BufferType | VoidType | Forgot + deriving (Eq, Ord) +{-! +deriving instance Binary Const +deriving instance NFData Const +!-} + +instance Sized Const where + size _ = 1 + +instance Pretty Const OutputAnnotation where + pretty (I i) = text . show $ i + pretty (BI i) = text . show $ i + pretty (Fl f) = text . show $ f + pretty (Ch c) = text . show $ c + pretty (Str s) = text s + pretty (AType a) = pretty a + pretty StrType = text "String" + pretty BufferType = text "prim__UnsafeBuffer" + pretty PtrType = text "Ptr" + pretty VoidType = text "Void" + pretty Forgot = text "Forgot" + pretty (B8 w) = text . show $ w + pretty (B16 w) = text . show $ w + pretty (B32 w) = text . show $ w + pretty (B64 w) = text . show $ w + +data Raw = Var Name + | RBind Name (Binder Raw) Raw + | RApp Raw Raw + | RType + | RForce Raw + | RConstant Const + deriving (Show, Eq) + +instance Sized Raw where + size (Var name) = 1 + size (RBind name bind right) = 1 + size bind + size right + size (RApp left right) = 1 + size left + size right + size RType = 1 + size (RForce raw) = 1 + size raw + size (RConstant const) = size const + +instance Pretty Raw OutputAnnotation where + pretty = text . show + +{-! +deriving instance Binary Raw +deriving instance NFData Raw +!-} + +-- The type parameter `b` will normally be something like `TT Name` or just +-- `Raw`. We do not make a type-level distinction between TT terms that happen +-- to be TT types and TT terms that are not TT types. +-- | All binding forms are represented in a uniform fashion. This type only represents +-- the types of bindings (and their values, if any); the attached identifiers are part +-- of the 'Bind' constructor for the 'TT' type. +data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}} + | Pi { binderTy :: !b } + {-^ A binding that occurs in a function type expression, e.g. @(x:Int) -> ...@ -} + | Let { binderTy :: !b, + binderVal :: b {-^ value for bound variable-}} + -- ^ A binding that occurs in a @let@ expression + | NLet { binderTy :: !b, + binderVal :: b } + | Hole { binderTy :: !b} + | GHole { envlen :: Int, + binderTy :: !b} + | Guess { binderTy :: !b, + binderVal :: b } + | PVar { binderTy :: !b } + -- ^ A pattern variable + | PVTy { binderTy :: !b } + deriving (Show, Eq, Ord, Functor) +{-! +deriving instance Binary Binder +deriving instance NFData Binder +!-} + +instance Sized a => Sized (Binder a) where + size (Lam ty) = 1 + size ty + size (Pi ty) = 1 + size ty + size (Let ty val) = 1 + size ty + size val + size (NLet ty val) = 1 + size ty + size val + size (Hole ty) = 1 + size ty + size (GHole _ ty) = 1 + size ty + size (Guess ty val) = 1 + size ty + size val + size (PVar ty) = 1 + size ty + size (PVTy ty) = 1 + size ty + +fmapMB :: Monad m => (a -> m b) -> Binder a -> m (Binder b) +fmapMB f (Let t v) = liftM2 Let (f t) (f v) +fmapMB f (NLet t v) = liftM2 NLet (f t) (f v) +fmapMB f (Guess t v) = liftM2 Guess (f t) (f v) +fmapMB f (Lam t) = liftM Lam (f t) +fmapMB f (Pi t) = liftM Pi (f t) +fmapMB f (Hole t) = liftM Hole (f t) +fmapMB f (GHole i t) = liftM (GHole i) (f t) +fmapMB f (PVar t) = liftM PVar (f t) +fmapMB f (PVTy t) = liftM PVTy (f t) + +raw_apply :: Raw -> [Raw] -> Raw +raw_apply f [] = f +raw_apply f (a : as) = raw_apply (RApp f a) as + +raw_unapply :: Raw -> (Raw, [Raw]) +raw_unapply t = ua [] t where + ua args (RApp f a) = ua (a:args) f + ua args t = (t, args) + +-- WELL TYPED TERMS --------------------------------------------------------- + +-- | Universe expressions for universe checking +data UExp = UVar Int -- ^ universe variable + | UVal Int -- ^ explicit universe level + deriving (Eq, Ord) +{-! +deriving instance NFData UExp +!-} + +instance Sized UExp where + size _ = 1 + +-- We assume that universe levels have been checked, so anything external +-- can just have the same universe variable and we won't get any new +-- cycles. + +instance Binary UExp where + put x = return () + get = return (UVar (-1)) + +instance Show UExp where + show (UVar x) | x < 26 = [toEnum (x + fromEnum 'a')] + | otherwise = toEnum ((x `mod` 26) + fromEnum 'a') : show (x `div` 26) + show (UVal x) = show x +-- show (UMax l r) = "max(" ++ show l ++ ", " ++ show r ++")" + +-- | Universe constraints +data UConstraint = ULT UExp UExp -- ^ Strictly less than + | ULE UExp UExp -- ^ Less than or equal to + deriving Eq + +instance Show UConstraint where + show (ULT x y) = show x ++ " < " ++ show y + show (ULE x y) = show x ++ " <= " ++ show y + +type UCs = (Int, [UConstraint]) + +data NameType = Bound + | Ref + | DCon {nt_tag :: Int, nt_arity :: Int} -- ^ Data constructor + | TCon {nt_tag :: Int, nt_arity :: Int} -- ^ Type constructor + deriving (Show, Ord) +{-! +deriving instance Binary NameType +deriving instance NFData NameType +!-} + +instance Sized NameType where + size _ = 1 + +instance Pretty NameType OutputAnnotation where + pretty = text . show + +instance Eq NameType where + Bound == Bound = True + Ref == Ref = True + DCon _ a == DCon _ b = (a == b) -- ignore tag + TCon _ a == TCon _ b = (a == b) -- ignore tag + _ == _ = False + +-- | Terms in the core language. The type parameter is the type of +-- identifiers used for bindings and explicit named references; +-- usually we use @TT 'Name'@. +data TT n = P NameType n (TT n) -- ^ named references with type + -- (P for "Parameter", motivated by McKinna and Pollack's + -- Pure Type Systems Formalized) + | V !Int -- ^ a resolved de Bruijn-indexed variable + | Bind n !(Binder (TT n)) (TT n) -- ^ a binding + | App !(TT n) (TT n) -- ^ function, function type, arg + | Constant Const -- ^ constant + | Proj (TT n) !Int -- ^ argument projection; runtime only + -- (-1) is a special case for 'subtract one from BI' + | Erased -- ^ an erased term + | Impossible -- ^ special case for totality checking + | TType UExp -- ^ the type of types at some level + deriving (Ord, Functor) +{-! +deriving instance Binary TT +deriving instance NFData TT +!-} + +class TermSize a where + termsize :: Name -> a -> Int + +instance TermSize a => TermSize [a] where + termsize n [] = 0 + termsize n (x : xs) = termsize n x + termsize n xs + +instance TermSize (TT Name) where + termsize n (P _ n' _) + | n' == n = 1000000 -- recursive => really big + | otherwise = 1 + termsize n (V _) = 1 + -- for `Bind` terms, we can erroneously declare a term + -- "recursive => really big" if the name of the bound + -- variable is the same as the name we're using + -- So generate a different name in that case. + termsize n (Bind n' (Let t v) sc) + = let rn = if n == n' then sMN 0 "noname" else n in + termsize rn v + termsize rn sc + termsize n (Bind n' b sc) + = let rn = if n == n' then sMN 0 "noname" else n in + termsize rn sc + termsize n (App f a) = termsize n f + termsize n a + termsize n (Proj t i) = termsize n t + termsize n _ = 1 + +instance Sized a => Sized (TT a) where + size (P name n trm) = 1 + size name + size n + size trm + size (V v) = 1 + size (Bind nm binder bdy) = 1 + size nm + size binder + size bdy + size (App l r) = 1 + size l + size r + size (Constant c) = size c + size Erased = 1 + size (TType u) = 1 + size u + +instance Pretty a o => Pretty (TT a) o where + pretty _ = text "test" + +type EnvTT n = [(n, Binder (TT n))] + +data Datatype n = Data { d_typename :: n, + d_typetag :: Int, + d_type :: (TT n), + d_cons :: [(n, TT n)] } + deriving (Show, Functor, Eq) + +instance Eq n => Eq (TT n) where + (==) (P xt x _) (P yt y _) = x == y + (==) (V x) (V y) = x == y + (==) (Bind _ xb xs) (Bind _ yb ys) = xs == ys && xb == yb + (==) (App fx ax) (App fy ay) = ax == ay && fx == fy + (==) (TType _) (TType _) = True -- deal with constraints later + (==) (Constant x) (Constant y) = x == y + (==) (Proj x i) (Proj y j) = x == y && i == j + (==) Erased _ = True + (==) _ Erased = True + (==) _ _ = False + +-- * A few handy operations on well typed terms: + +-- | A term is injective iff it is a data constructor, type constructor, +-- constant, the type Type, pi-binding, or an application of an injective +-- term. +isInjective :: TT n -> Bool +isInjective (P (DCon _ _) _ _) = True +isInjective (P (TCon _ _) _ _) = True +isInjective (Constant _) = True +isInjective (TType x) = True +isInjective (Bind _ (Pi _) sc) = True +isInjective (App f a) = isInjective f +isInjective _ = False + +-- | Count the number of instances of a de Bruijn index in a term +vinstances :: Int -> TT n -> Int +vinstances i (V x) | i == x = 1 +vinstances i (App f a) = vinstances i f + vinstances i a +vinstances i (Bind x b sc) = instancesB b + vinstances (i + 1) sc + where instancesB (Let t v) = vinstances i v + instancesB _ = 0 +vinstances i t = 0 + +-- | Replace the outermost (index 0) de Bruijn variable with the given term +instantiate :: TT n -> TT n -> TT n +instantiate e = subst 0 where + subst i (V x) | i == x = e + subst i (Bind x b sc) = Bind x (fmap (subst i) b) (subst (i+1) sc) + subst i (App f a) = App (subst i f) (subst i a) + subst i (Proj x idx) = Proj (subst i x) idx + subst i t = t + +-- | As 'instantiate', but also decrement the indices of all de Bruijn variables +-- remaining in the term, so that there are no more references to the variable +-- that has been substituted. +substV :: TT n -> TT n -> TT n +substV x tm = dropV 0 (instantiate x tm) where + dropV i (V x) | x > i = V (x - 1) + | otherwise = V x + dropV i (Bind x b sc) = Bind x (fmap (dropV i) b) (dropV (i+1) sc) + dropV i (App f a) = App (dropV i f) (dropV i a) + dropV i (Proj x idx) = Proj (dropV i x) idx + dropV i t = t + +-- | Replace all non-free de Bruijn references in the given term with references +-- to the name of their binding. +explicitNames :: TT n -> TT n +explicitNames (Bind x b sc) = let b' = fmap explicitNames b in + Bind x b' + (explicitNames (instantiate + (P Bound x (binderTy b')) sc)) +explicitNames (App f a) = App (explicitNames f) (explicitNames a) +explicitNames (Proj x idx) = Proj (explicitNames x) idx +explicitNames t = t + +-- | Replace references to the given 'Name'-like id with references to +-- de Bruijn index 0. +pToV :: Eq n => n -> TT n -> TT n +pToV n = pToV' n 0 +pToV' n i (P _ x _) | n == x = V i +pToV' n i (Bind x b sc) +-- We can assume the inner scope has been pToVed already, so continue to +-- resolve names from the *outer* scope which may happen to have the same id. + | n == x = Bind x (fmap (pToV' n i) b) sc + | otherwise = Bind x (fmap (pToV' n i) b) (pToV' n (i+1) sc) +pToV' n i (App f a) = App (pToV' n i f) (pToV' n i a) +pToV' n i (Proj t idx) = Proj (pToV' n i t) idx +pToV' n i t = t + +-- increase de Bruijn indices, as if a binder has been added +addBinder :: TT n -> TT n +addBinder t = ab 0 t + where + ab top (V i) | i >= top = V (i + 1) + | otherwise = V i + ab top (Bind x b sc) = Bind x (fmap (ab top) b) (ab (top + 1) sc) + ab top (App f a) = App (ab top f) (ab top a) + ab top (Proj t idx) = Proj (ab top t) idx + ab top t = t + +-- | Convert several names. First in the list comes out as V 0 +pToVs :: Eq n => [n] -> TT n -> TT n +pToVs ns tm = pToVs' ns tm 0 where + pToVs' [] tm i = tm + pToVs' (n:ns) tm i = pToV' n i (pToVs' ns tm (i+1)) + +-- | Replace de Bruijn indices in the given term with explicit references to +-- the names of the bindings they refer to. It is an error if the given term +-- contains free de Bruijn indices. +vToP :: TT n -> TT n +vToP = vToP' [] where + vToP' env (V i) = let (n, b) = (env !! i) in + P Bound n (binderTy b) + vToP' env (Bind n b sc) = let b' = fmap (vToP' env) b in + Bind n b' (vToP' ((n, b'):env) sc) + vToP' env (App f a) = App (vToP' env f) (vToP' env a) + vToP' env t = t + +-- | Replace every non-free reference to the name of a binding in +-- the given term with a de Bruijn index. +finalise :: Eq n => TT n -> TT n +finalise (Bind x b sc) = Bind x (fmap finalise b) (pToV x (finalise sc)) +finalise (App f a) = App (finalise f) (finalise a) +finalise t = t + +-- Once we've finished checking everything about a term we no longer need +-- the type on the 'P' so erase it so save memory + +pEraseType :: TT n -> TT n +pEraseType (P nt t _) = P nt t Erased +pEraseType (App f a) = App (pEraseType f) (pEraseType a) +pEraseType (Bind n b sc) = Bind n (fmap pEraseType b) (pEraseType sc) +pEraseType t = t + +-- | As 'instantiate', but in addition to replacing @'V' 0@, +-- replace references to the given 'Name'-like id. +subst :: Eq n => n {-^ The id to replace -} -> + TT n {-^ The replacement term -} -> + TT n {-^ The term to replace in -} -> + TT n +subst n v tm = instantiate v (pToV n tm) + +-- If there are no Vs in the term (i.e. in proof state) +psubst :: Eq n => n -> TT n -> TT n -> TT n +psubst n v tm = s' tm where + s' (P _ x _) | n == x = v + s' (Bind x b sc) | n == x = Bind x (fmap s' b) sc + | otherwise = Bind x (fmap s' b) (s' sc) + s' (App f a) = App (s' f) (s' a) + s' (Proj t idx) = Proj (s' t) idx + s' t = t + +-- | As 'subst', but takes a list of (name, substitution) pairs instead +-- of a single name and substitution +substNames :: Eq n => [(n, TT n)] -> TT n -> TT n +substNames [] t = t +substNames ((n, tm) : xs) t = subst n tm (substNames xs t) + +-- | Replaces all terms equal (in the sense of @(==)@) to +-- the old term with the new term. +substTerm :: Eq n => TT n {-^ Old term -} -> + TT n {-^ New term -} -> + TT n {-^ template term -} + -> TT n +substTerm old new = st where + st t | t == old = new + st (App f a) = App (st f) (st a) + st (Bind x b sc) = Bind x (fmap st b) (st sc) + st t = t + +-- | Returns true if V 0 and bound name n do not occur in the term +noOccurrence :: Eq n => n -> TT n -> Bool +noOccurrence n t = no' 0 t + where + no' i (V x) = not (i == x) + no' i (P Bound x _) = not (n == x) + no' i (Bind n b sc) = noB' i b && no' (i+1) sc + where noB' i (Let t v) = no' i t && no' i v + noB' i (Guess t v) = no' i t && no' i v + noB' i b = no' i (binderTy b) + no' i (App f a) = no' i f && no' i a + no' i (Proj x _) = no' i x + no' i _ = True + +-- | Returns all names used free in the term +freeNames :: Eq n => TT n -> [n] +freeNames (P _ n _) = [n] +freeNames (Bind n (Let t v) sc) = nub $ freeNames v ++ (freeNames sc \\ [n]) + ++ freeNames t +freeNames (Bind n b sc) = nub $ freeNames (binderTy b) ++ (freeNames sc \\ [n]) +freeNames (App f a) = nub $ freeNames f ++ freeNames a +freeNames (Proj x i) = nub $ freeNames x +freeNames _ = [] + +-- | Return the arity of a (normalised) type +arity :: TT n -> Int +arity (Bind n (Pi t) sc) = 1 + arity sc +arity _ = 0 + +-- | Deconstruct an application; returns the function and a list of arguments +unApply :: TT n -> (TT n, [TT n]) +unApply t = ua [] t where + ua args (App f a) = ua (a:args) f + ua args t = (t, args) + +-- | Returns a term representing the application of the first argument +-- (a function) to every element of the second argument. +mkApp :: TT n -> [TT n] -> TT n +mkApp f [] = f +mkApp f (a:as) = mkApp (App f a) as + +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 + +-- | Cast a 'TT' term to a 'Raw' value, discarding universe information and +-- the types of named references and replacing all de Bruijn indices +-- with the corresponding name. It is an error if there are free de +-- Bruijn indices. +forget :: TT Name -> Raw +forget tm = fe [] tm + where + fe env (P _ n _) = Var n + fe env (V i) = Var (env !! i) + fe env (Bind n b sc) = let n' = uniqueName n env in + RBind n' (fmap (fe env) b) + (fe (n':env) sc) + fe env (App f a) = RApp (fe env f) (fe env a) + fe env (Constant c) + = RConstant c + fe env (TType i) = RType + fe env Erased = RConstant Forgot + +-- | Introduce a 'Bind' into the given term for each element of the +-- given list of (name, binder) pairs. +bindAll :: [(n, Binder (TT n))] -> TT n -> TT n +bindAll [] t = t +bindAll ((n, b) : bs) t = Bind n b (bindAll bs t) + +-- | Like 'bindAll', but the 'Binder's are 'TT' terms instead. +-- The first argument is a function to map @TT@ terms to @Binder@s. +-- This function might often be something like 'Lam', which directly +-- constructs a @Binder@ from a @TT@ term. +bindTyArgs :: (TT n -> Binder (TT n)) -> [(n, TT n)] -> TT n -> TT n +bindTyArgs b xs = bindAll (map (\ (n, ty) -> (n, b ty)) xs) + +-- | Return a list of pairs of the names of the outermost 'Pi'-bound +-- variables in the given term, together with their types. +getArgTys :: TT n -> [(n, TT n)] +getArgTys (Bind n (Pi t) sc) = (n, t) : getArgTys sc +getArgTys _ = [] + +getRetTy :: TT n -> TT n +getRetTy (Bind n (PVar _) sc) = getRetTy sc +getRetTy (Bind n (PVTy _) sc) = getRetTy sc +getRetTy (Bind n (Pi _) sc) = getRetTy sc +getRetTy sc = sc + +uniqueNameFrom :: [Name] -> [Name] -> Name +uniqueNameFrom (s : supply) hs + | s `elem` hs = uniqueNameFrom supply hs + | otherwise = s + +uniqueName :: Name -> [Name] -> Name +uniqueName n hs | n `elem` hs = uniqueName (nextName n) hs + | otherwise = n + +uniqueBinders :: [Name] -> TT Name -> TT Name +uniqueBinders ns (Bind n b sc) + = let n' = uniqueName n ns in + Bind n' (fmap (uniqueBinders (n':ns)) b) (uniqueBinders ns sc) +uniqueBinders ns (App f a) = App (uniqueBinders ns f) (uniqueBinders ns a) +uniqueBinders ns t = t + + +nextName (NS x s) = NS (nextName x) s +nextName (MN i n) = MN (i+1) n +nextName (UN x) = let (num', nm') = T.span isDigit (T.reverse x) + nm = T.reverse nm' + num = readN (T.reverse num') in + UN (nm `T.append` txt (show (num+1))) + where + readN x | not (T.null x) = read (T.unpack x) + readN x = 0 +nextName (SN x) = SN (nextName' x) + where + nextName' (WhereN i f x) = WhereN i f (nextName x) + nextName' (CaseN n) = CaseN (nextName n) + nextName' (MethodN n) = MethodN (nextName n) + +type Term = TT Name +type Type = Term + +type Env = EnvTT Name + +-- | an environment with de Bruijn indices 'normalised' so that they all refer to +-- this environment + +newtype WkEnvTT n = Wk (EnvTT n) +type WkEnv = WkEnvTT Name + +instance (Eq n, Show n) => Show (TT n) where + show t = showEnv [] t + +itBitsName IT8 = "Bits8" +itBitsName IT16 = "Bits16" +itBitsName IT32 = "Bits32" +itBitsName IT64 = "Bits64" + +instance Show Const where + show (I i) = show i + show (BI i) = show i + show (Fl f) = show f + show (Ch c) = show c + show (Str s) = show s + show (B8 x) = show x + show (B16 x) = show x + show (B32 x) = show x + show (B64 x) = show x + show (B8V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" + show (B16V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" + show (B32V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" + show (B64V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">" + show (AType ATFloat) = "Float" + show (AType (ATInt ITBig)) = "Integer" + show (AType (ATInt ITNative)) = "Int" + show (AType (ATInt ITChar)) = "Char" + show (AType (ATInt (ITFixed it))) = itBitsName it + show (AType (ATInt (ITVec it c))) = itBitsName it ++ "x" ++ show c + show StrType = "String" + show BufferType = "prim__UnsafeBuffer" + show PtrType = "Ptr" + show VoidType = "Void" + +showEnv :: (Eq n, Show n) => EnvTT n -> TT n -> String +showEnv env t = showEnv' env t False +showEnvDbg env t = showEnv' env t True + +prettyEnv env t = prettyEnv' env t False + where + prettyEnv' env t dbg = prettySe 10 env t dbg + + bracket outer inner p + | inner > outer = lparen <> p <> rparen + | otherwise = p + + prettySe p env (P nt n t) debug = + pretty n <+> + if debug then + lbracket <+> pretty nt <+> colon <+> prettySe 10 env t debug <+> rbracket + else + empty + prettySe p env (V i) debug + | i < length env = + if debug then + text . show . fst $ env!!i + else + lbracket <+> text (show i) <+> rbracket + | otherwise = text "unbound" <+> text (show i) <+> text "!" + prettySe p env (Bind n b@(Pi t) sc) debug + | noOccurrence n sc && not debug = + bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug + prettySe p env (Bind n b sc) debug = + bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug + prettySe p env (App f a) debug = + bracket p 1 $ prettySe 1 env f debug <+> prettySe 0 env a debug + prettySe p env (Proj x i) debug = + prettySe 1 env x debug <+> text ("!" ++ show i) + prettySe p env (Constant c) debug = pretty c + prettySe p env Erased debug = text "[_]" + prettySe p env (TType i) debug = text "Type" <+> (text . show $ i) + + -- Render a `Binder` and its name + prettySb env n (Lam t) = prettyB env "λ" "=>" n t + prettySb env n (Hole t) = prettyB env "?defer" "." n t + prettySb env n (Pi t) = prettyB env "(" ") ->" n t + prettySb env n (PVar t) = prettyB env "pat" "." n t + prettySb env n (PVTy t) = prettyB env "pty" "." n t + prettySb env n (Let t v) = prettyBv env "let" "in" n t v + prettySb env n (Guess t v) = prettyBv env "??" "in" n t v + + -- Use `op` and `sc` to delimit `n` (a binding name) and its type + -- declaration + -- e.g. "λx : Int =>" for the Lam case + prettyB env op sc n t debug = + text op <> pretty n <+> colon <+> prettySe 10 env t debug <> text sc + + -- Like `prettyB`, but handle the bindings that have values in addition + -- to names and types + prettyBv env op sc n t v debug = + text op <> pretty n <+> colon <+> prettySe 10 env t debug <+> text "=" <+> + prettySe 10 env v debug <> text sc + + +showEnv' env t dbg = se 10 env t where + se p env (P nt n t) = show n + ++ if dbg then "{" ++ show nt ++ " : " ++ se 10 env t ++ "}" else "" + se p env (V i) | i < length env && i >= 0 + = (show $ fst $ env!!i) ++ + if dbg then "{" ++ show i ++ "}" else "" + | otherwise = "!!V " ++ show i ++ "!!" + se p env (Bind n b@(Pi t) sc) + | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ " -> " ++ se 10 ((n,b):env) sc + se p env (Bind n b sc) = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc + se p env (App f a) = bracket p 1 $ se 1 env f ++ " " ++ se 0 env a + se p env (Proj x i) = se 1 env x ++ "!" ++ show i + se p env (Constant c) = show c + se p env Erased = "[__]" + se p env Impossible = "[impossible]" + se p env (TType i) = "Type " ++ show i + + sb env n (Lam t) = showb env "\\ " " => " n t + sb env n (Hole t) = showb env "? " ". " n t + sb env n (GHole i t) = showb env "?defer " ". " n t + sb env n (Pi t) = showb env "(" ") -> " n t + sb env n (PVar t) = showb env "pat " ". " n t + sb env n (PVTy t) = showb env "pty " ". " n t + sb env n (Let t v) = showbv env "let " " in " n t v + sb env n (Guess t v) = showbv env "?? " " in " n t v + + showb env op sc n t = op ++ show n ++ " : " ++ se 10 env t ++ sc + showbv env op sc n t v = op ++ show n ++ " : " ++ se 10 env t ++ " = " ++ + se 10 env v ++ sc + + bracket outer inner str | inner > outer = "(" ++ str ++ ")" + | otherwise = str + +-- | Check whether a term has any holes in it - impure if so +pureTerm :: TT Name -> Bool +pureTerm (App f a) = pureTerm f && pureTerm a +pureTerm (Bind n b sc) = notClassName n && pureBinder b && pureTerm sc where + pureBinder (Hole _) = False + pureBinder (Guess _ _) = False + pureBinder (Let t v) = pureTerm t && pureTerm v + pureBinder t = pureTerm (binderTy t) + + notClassName (MN _ c) | c == txt "class" = False + notClassName _ = True + +pureTerm _ = True + +-- | Weaken a term by adding i to each de Bruijn index (i.e. lift it over i bindings) +weakenTm :: Int -> TT n -> TT n +weakenTm i t = wk i 0 t + where wk i min (V x) | x >= min = V (i + x) + wk i m (App f a) = App (wk i m f) (wk i m a) + wk i m (Bind x b sc) = Bind x (wkb i m b) (wk i (m + 1) sc) + wk i m t = t + wkb i m t = fmap (wk i m) t + +-- | Weaken an environment so that all the de Bruijn indices are correct according +-- to the latest bound variable + +weakenEnv :: EnvTT n -> EnvTT n +weakenEnv env = wk (length env - 1) env + where wk i [] = [] + wk i ((n, b) : bs) = (n, weakenTmB i b) : wk (i - 1) bs + weakenTmB i (Let t v) = Let (weakenTm i t) (weakenTm i v) + weakenTmB i (Guess t v) = Guess (weakenTm i t) (weakenTm i v) + weakenTmB i t = t { binderTy = weakenTm i (binderTy t) } + +-- | Weaken every term in the environment by the given amount +weakenTmEnv :: Int -> EnvTT n -> EnvTT n +weakenTmEnv i = map (\ (n, b) -> (n, fmap (weakenTm i) b)) + +-- | Gather up all the outer 'PVar's and 'Hole's in an expression and reintroduce +-- them in a canonical order +orderPats :: Term -> Term +orderPats tm = op [] tm + where + op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc + op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc + op ps sc = bindAll (sortP ps) sc + + sortP ps = pick [] (reverse ps) + + namesIn (P _ n _) = [n] + namesIn (Bind n b t) = nub $ nb b ++ (namesIn t \\ [n]) + where nb (Let t v) = nub (namesIn t) ++ nub (namesIn v) + nb (Guess t v) = nub (namesIn t) ++ nub (namesIn v) + nb t = namesIn (binderTy t) + namesIn (App f a) = nub (namesIn f ++ namesIn a) + namesIn _ = [] + + pick acc [] = reverse acc + pick acc ((n, t) : ps) = pick (insert n t acc) ps + + insert n t [] = [(n, t)] + insert n t ((n',t') : ps) + | n `elem` (namesIn (binderTy t') ++ + concatMap namesIn (map (binderTy . snd) ps)) + = (n', t') : insert n t ps + | otherwise = (n,t):(n',t'):ps + diff --git a/src/Idris/Core/Typecheck.hs b/src/Idris/Core/Typecheck.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Core/Typecheck.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, + PatternGuards #-} + +module Idris.Core.Typecheck where + +import Control.Monad.State +import Debug.Trace +import qualified Data.Vector.Unboxed as V (length) + +import Idris.Core.TT +import Idris.Core.Evaluate + +-- To check conversion, normalise each term wrt the current environment. +-- Since we haven't converted everything to de Bruijn indices yet, we'll have to +-- deal with alpha conversion - we do this by making each inner term de Bruijn +-- indexed with 'finalise' + +convertsC :: Context -> Env -> Term -> Term -> StateT UCs TC () +convertsC ctxt env x y + = do c1 <- convEq ctxt x y + if c1 then return () + else + do c2 <- convEq ctxt (finalise (normalise ctxt env x)) + (finalise (normalise ctxt env y)) + if c2 then return () + else lift $ tfail (CantConvert + (finalise (normalise ctxt env x)) + (finalise (normalise ctxt env y)) (errEnv env)) + +converts :: Context -> Env -> Term -> Term -> TC () +converts ctxt env x y + = case convEq' ctxt x y of + OK True -> return () + _ -> case convEq' ctxt (finalise (normalise ctxt env x)) + (finalise (normalise ctxt env y)) of + OK True -> return () + _ -> tfail (CantConvert + (finalise (normalise ctxt env x)) + (finalise (normalise ctxt env y)) (errEnv env)) + +errEnv = map (\(x, b) -> (x, binderTy b)) + +isType :: Context -> Env -> Term -> TC () +isType ctxt env tm = isType' (normalise ctxt env tm) + where isType' (TType _) = return () + isType' tm = fail (showEnv env tm ++ " is not a TType") + +recheck :: Context -> Env -> Raw -> Term -> TC (Term, Type, UCs) +recheck ctxt env tm orig + = let v = next_tvar ctxt in + case runStateT (check' False ctxt env tm) (v, []) of -- holes banned + Error (IncompleteTerm _) -> Error $ IncompleteTerm orig + Error e -> Error e + OK ((tm, ty), constraints) -> + return (tm, ty, constraints) + +check :: Context -> Env -> Raw -> TC (Term, Type) +check ctxt env tm = evalStateT (check' True ctxt env tm) (0, []) -- Holes allowed + +check' :: Bool -> Context -> Env -> Raw -> StateT UCs TC (Term, Type) +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 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 + (av, aty) <- chk env a + let fty' = case uniqueBinders (map fst env) (finalise fty) of + ty@(Bind x (Pi s) t) -> ty + _ -> uniqueBinders (map fst env) + $ case hnf ctxt env fty of + ty@(Bind x (Pi s) t) -> ty + _ -> normalise ctxt env fty + case fty' of + Bind x (Pi s) t -> +-- trace ("Converting " ++ show aty ++ " and " ++ show s ++ +-- " from " ++ show fv ++ " : " ++ show fty) $ + do convertsC ctxt env aty s + -- let apty = normalise initContext env + -- (Bind x (Let aty av) t) + let apty = simplify initContext env + (Bind x (Let aty av) t) + return (App fv av, apty) + 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 + -- generated names, we'll be fine. + -- NOTE: now replaced with 'uniqueBinders' above + where renameBinders i (Bind x (Pi s) t) = Bind (sMN i "binder") (Pi s) + (renameBinders (i+1) t) + renameBinders i sc = sc + chk env RType + | holes = return (TType (UVal 0), TType (UVal 0)) + | otherwise = do (v, cs) <- get + let c = ULT (UVar v) (UVar (v+1)) + put (v+2, (c:cs)) + return (TType (UVar v), TType (UVar (v+1))) + chk env (RConstant Forgot) = return (Erased, Erased) + chk env (RConstant c) = return (Constant c, constType c) + where constType (I _) = Constant (AType (ATInt ITNative)) + constType (BI _) = Constant (AType (ATInt ITBig)) + constType (Fl _) = Constant (AType ATFloat) + constType (Ch _) = Constant (AType (ATInt ITChar)) + constType (Str _) = Constant StrType + constType (B8 _) = Constant (AType (ATInt (ITFixed IT8))) + constType (B16 _) = Constant (AType (ATInt (ITFixed IT16))) + constType (B32 _) = Constant (AType (ATInt (ITFixed IT32))) + constType (B64 _) = Constant (AType (ATInt (ITFixed IT64))) + constType (B8V a) = Constant (AType (ATInt (ITVec IT8 (V.length a)))) + constType (B16V a) = Constant (AType (ATInt (ITVec IT16 (V.length a)))) + constType (B32V a) = Constant (AType (ATInt (ITVec IT32 (V.length a)))) + constType (B64V a) = Constant (AType (ATInt (ITVec IT64 (V.length a)))) + constType Forgot = Erased + constType _ = TType (UVal 0) + chk env (RForce t) = do (_, ty) <- chk env t + return (Erased, ty) + chk env (RBind n (Pi s) t) + = do (sv, st) <- chk env s + (tv, tt) <- chk ((n, Pi sv) : env) t + (v, cs) <- get + let TType su = normalise ctxt env st + let TType tu = normalise ctxt env tt + when (not holes) $ put (v+1, ULE su (UVar v):ULE tu (UVar v):cs) + return (Bind n (Pi (uniqueBinders (map fst env) sv)) + (pToV n tv), TType (UVar v)) + chk env (RBind n b sc) + = do b' <- checkBinder b + (scv, sct) <- chk ((n, b'):env) sc + discharge n b' (pToV n scv) (pToV n sct) + where checkBinder (Lam t) + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isType ctxt env tt' + return (Lam tv) + checkBinder (Pi t) + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isType ctxt env tt' + return (Pi tv) + checkBinder (Let t v) + = do (tv, tt) <- chk env t + (vv, vt) <- chk env v + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + convertsC ctxt env vt tv + lift $ isType ctxt env tt' + return (Let tv vv) + checkBinder (NLet t v) + = do (tv, tt) <- chk env t + (vv, vt) <- chk env v + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + convertsC ctxt env vt tv + lift $ isType ctxt env tt' + return (NLet tv vv) + checkBinder (Hole t) + | not holes = lift $ tfail (IncompleteTerm undefined) + | otherwise + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isType ctxt env tt' + return (Hole tv) + checkBinder (GHole i t) + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isType ctxt env tt' + return (GHole i tv) + checkBinder (Guess t v) + | not holes = lift $ tfail (IncompleteTerm undefined) + | otherwise + = do (tv, tt) <- chk env t + (vv, vt) <- chk env v + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + convertsC ctxt env vt tv + lift $ isType ctxt env tt' + return (Guess tv vv) + checkBinder (PVar t) + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isType ctxt env tt' + -- Normalised version, for erasure purposes (it's easier + -- to tell if it's a collapsible variable) + return (PVar tv) + checkBinder (PVTy t) + = do (tv, tt) <- chk env t + let tv' = normalise ctxt env tv + let tt' = normalise ctxt env tt + lift $ isType ctxt env tt' + return (PVTy tv) + + discharge n (Lam t) scv sct + = return (Bind n (Lam t) scv, Bind n (Pi t) sct) + discharge n (Pi t) scv sct + = return (Bind n (Pi t) scv, sct) + discharge n (Let t v) scv sct + = return (Bind n (Let t v) scv, Bind n (Let t v) sct) + discharge n (NLet t v) scv sct + = return (Bind n (NLet t v) scv, Bind n (Let t v) sct) + discharge n (Hole t) scv sct + = return (Bind n (Hole t) scv, sct) + discharge n (GHole i t) scv sct + = return (Bind n (GHole i t) scv, sct) + discharge n (Guess t v) scv sct + = return (Bind n (Guess t v) scv, sct) + discharge n (PVar t) scv sct + = return (Bind n (PVar t) scv, Bind n (PVTy t) sct) + discharge n (PVTy t) scv sct + = return (Bind n (PVTy t) scv, sct) diff --git a/src/Idris/Core/Unify.hs b/src/Idris/Core/Unify.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Core/Unify.hs @@ -0,0 +1,560 @@ +{-# LANGUAGE PatternGuards #-} + +module Idris.Core.Unify(match_unify, unify, Fails) where + +import Idris.Core.TT +import Idris.Core.Evaluate + +import Control.Monad +import Control.Monad.State.Strict +import Data.List +import Debug.Trace + +-- Unification is applied inside the theorem prover. We're looking for holes +-- which can be filled in, by matching one term's normal form against another. +-- Returns a list of hole names paired with the term which solves them, and +-- a list of things which need to be injective. + +-- terms which need to be injective, with the things we're trying to unify +-- at the time + +type Injs = [(TT Name, TT Name, TT Name)] +type Fails = [(TT Name, TT Name, Env, Err)] + +data UInfo = UI Int Fails + deriving Show + +data UResult a = UOK a + | UPartOK a + | UFail Err + +-- Solve metavariables by matching terms against each other +-- Not really unification, of course! + +match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> + TC [(Name, TT Name)] +match_unify ctxt env topx topy dont holes = + case runStateT (un [] topx topy) (UI 0 []) of + OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v)) + res -> + let topxn = normalise ctxt env topx + topyn = normalise ctxt env topy in + case runStateT (un [] topxn topyn) + (UI 0 []) of + OK (v, UI _ fails) -> + return (map (renameBinders env) (trimSolutions v)) + Error e -> + -- just normalise the term we're matching against + case runStateT (un [] topxn topy) + (UI 0 []) of + OK (v, UI _ fails) -> + return (map (renameBinders env) (trimSolutions v)) + _ -> tfail e + where + + + un names (P _ x _) tm + | holeIn env x || x `elem` holes + = do sc 1; checkCycle names (x, tm) + un names tm (P _ y _) + | holeIn env y || y `elem` holes + = do sc 1; checkCycle names (y, tm) + un bnames (V i) (P _ x _) + | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] + un bnames (P _ x _) (V i) + | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] + un bnames (Bind x bx sx) (Bind y by sy) + = do h1 <- uB bnames bx by + h2 <- un ((x, y) : bnames) sx sy + combine bnames h1 h2 + un names (App fx ax) (App fy ay) + = do hf <- un names fx fy + ha <- un names ax ay + combine names hf ha + un names x y + | OK True <- convEq' ctxt x y = do sc 1; return [] + | otherwise = do UI s f <- get + let r = recoverable x y + let err = CantUnify r + topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s + if (not r) then lift $ tfail err + else do put (UI s ((x, y, env, err) : f)) + lift $ tfail err + + + uB bnames (Let tx vx) (Let ty vy) = do h1 <- un bnames tx ty + h2 <- un bnames vx vy + combine bnames h1 h2 + uB bnames (Lam tx) (Lam ty) = un bnames tx ty + uB bnames (Pi tx) (Pi ty) = un bnames tx ty + uB bnames x y = do UI s f <- get + let r = recoverable (binderTy x) (binderTy y) + let err = CantUnify r topx topy + (CantUnify r (binderTy x) (binderTy y) (Msg "") [] s) + (errEnv env) s + put (UI s ((binderTy x, binderTy y, env, err) : f)) + return [] + + -- TODO: there's an annoying amount of repetition between this and the + -- main unification function. Consider lifting it out. + + sc i = do UI s f <- get + put (UI (s+i) f) + + unifyFail x y = do UI s f <- get + let r = recoverable x y + let err = CantUnify r + topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s + put (UI s ((x, y, env, err) : f)) + lift $ tfail err + combine bnames as [] = return as + combine bnames as ((n, t) : bs) + = case lookup n as of + Nothing -> combine bnames (as ++ [(n,t)]) bs + Just t' -> do ns <- un bnames t t' + -- make sure there's n mapping from n in ns + let ns' = filter (\ (x, _) -> x/=n) ns + sc 1 + combine bnames as (ns' ++ bs) + + checkCycle ns p@(x, P _ _ _) = return [p] + checkCycle ns (x, tm) + | not (x `elem` freeNames tm) = checkScope ns (x, tm) + | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) + + checkScope ns (x, tm) = + case boundVs (envPos x 0 env) tm of + [] -> return [(x, tm)] + (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i)) + (inst ns tm) (errEnv env)) + where inst [] tm = tm + inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm) + +renameBinders :: Env -> (Name, TT Name) -> (Name, TT Name) +renameBinders env (x, tm) = (x, uniqueBinders tm) + where + uniqueBinders (Bind n b sc) + | n `elem` map fst env + = let n' = uniqueName n (map fst env) in + Bind n' (fmap uniqueBinders b) + (uniqueBinders (rename n n' sc)) + | otherwise = Bind n (fmap uniqueBinders b) (uniqueBinders sc) + uniqueBinders (App f a) = App (uniqueBinders f) (uniqueBinders a) + uniqueBinders t = t + + rename n n' (P nt x ty) | n == x = P nt n' ty + rename n n' (Bind x b sc) = Bind x (fmap (rename n n') b) (rename n n' sc) + rename n n' (App f a) = App (rename n n' f) (rename n n' a) + rename n n' t = t + +trimSolutions ns = dropPairs ns + where dropPairs [] = [] + dropPairs (n@(x, P _ x' _) : ns) + | x == x' = dropPairs ns + | otherwise + = n : dropPairs + (filter (\t -> case t of + (n, P _ n' _) -> not (n == x' && n' == x) + _ -> True) ns) + dropPairs (n : ns) = n : dropPairs ns + +expandLets env (x, tm) = (x, doSubst (reverse env) tm) + where + doSubst [] tm = tm + doSubst ((n, Let v t) : env) tm + = doSubst env (subst n v tm) + doSubst (_ : env) tm + = doSubst env tm + + +unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> + TC ([(Name, TT Name)], Fails) +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 + OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v), + []) + res -> + let topxn = normalise ctxt env topx + topyn = normalise ctxt env topy in +-- trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n" ++ show res ++ "\n\n") $ + case runStateT (un False [] topxn topyn) + (UI 0 []) of + OK (v, UI _ fails) -> + return (map (renameBinders env) (trimSolutions v), + reverse fails) +-- Error e@(CantUnify False _ _ _ _ _) -> tfail e + Error e -> tfail e + where + headDiff (P (DCon _ _) x _) (P (DCon _ _) y _) = x /= y + headDiff (P (TCon _ _) x _) (P (TCon _ _) y _) = x /= y + headDiff _ _ = False + + injective (P (DCon _ _) _ _) = True + injective (P (TCon _ _) _ _) = True +-- 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 + notP _ = True + + sc i = do UI s f <- get + put (UI (s+i) f) + + errors = do UI s f <- get + return (not (null f)) + + uplus u1 u2 = do UI s f <- get + r <- u1 + UI s f' <- get + if (length f == length f') + then return r + else do put (UI s f); u2 + + un :: Bool -> [(Name, Name)] -> TT Name -> TT Name -> + StateT UInfo + TC [(Name, TT Name)] + un = un' +-- un fn names x y +-- = let (xf, _) = unApply x +-- (yf, _) = unApply y in +-- if headDiff xf yf then unifyFail x y else +-- uplus (un' fn names x y) +-- (un' fn names (hnf ctxt env x) (hnf ctxt env y)) + + un' :: Bool -> [(Name, Name)] -> TT Name -> TT Name -> + StateT UInfo + TC [(Name, TT Name)] + un' fn names x y | x == y = return [] -- shortcut + un' fn names topx@(P (DCon _ _) x _) topy@(P (DCon _ _) y _) + | x /= y = unifyFail topx topy + un' fn names topx@(P (TCon _ _) x _) topy@(P (TCon _ _) y _) + | x /= y = unifyFail topx topy + un' fn names topx@(P (DCon _ _) x _) topy@(P (TCon _ _) y _) + = 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) + = unifyTmpFail tx ty + | injective ty && not (holeIn env x || x `elem` holes) + = unifyTmpFail tx ty + un' fn bnames xtm@(P _ x _) tm + | holeIn env x || x `elem` holes + = do UI s f <- get + -- injectivity check + if (notP tm && fn) +-- trace (show (x, tm, normalise ctxt env tm)) $ +-- put (UI s ((tm, topx, topy) : i) f) + then unifyTmpFail xtm tm + else do sc 1 + checkCycle bnames (x, tm) + | not (injective xtm) && injective tm = unifyFail xtm tm + un' fn bnames tm ytm@(P _ y _) + | holeIn env y || y `elem` holes + = do UI s f <- get + -- injectivity check + if (notP tm && fn) +-- trace (show (y, tm, normalise ctxt env tm)) $ +-- put (UI s ((tm, topx, topy) : i) f) + then unifyTmpFail tm ytm + else do sc 1 + checkCycle bnames (y, tm) + | not (injective ytm) && injective tm = unifyFail ytm tm + un' fn bnames (V i) (P _ x _) + | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] + un' fn bnames (P _ x _) (V i) + | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] + + un' fn bnames appx@(App _ _) appy@(App _ _) + = unApp fn bnames appx appy +-- = uplus (unApp fn bnames appx appy) +-- (unifyTmpFail appx appy) -- take the whole lot + + un' fn bnames x (Bind n (Lam t) (App y (P Bound n' _))) + | 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) +-- = un' False ((x,y):bnames) sx sy + + -- f D unifies with t -> D. This is dubious, but it helps with type + -- class resolution for type classes over functions. + + un' fn bnames (App f x) (Bind n (Pi t) y) + | noOccurrence n y && x == y + = un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) + (Bind n (Pi t) (V 1))) + + un' fn bnames (Bind x bx sx) (Bind y by sy) + = do h1 <- uB bnames bx by + h2 <- un' False ((x,y):bnames) sx sy + combine bnames h1 h2 + un' fn bnames x y + | OK True <- convEq' ctxt x y = do sc 1; return [] + | otherwise = do UI s f <- get + let r = recoverable x y + let err = CantUnify r + topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s + if (not r) then lift $ tfail err + else do put (UI s ((x, y, env, err) : f)) + return [] -- lift $ tfail err + + unApp fn bnames appx@(App fx ax) appy@(App fy ay) + | (injective fx && injective fy) + || (injective fx && rigid appx && metavarApp appy) + || (injective fy && rigid appy && metavarApp appx) + || (injective fx && metavarApp fy && ax == ay) + || (injective fy && metavarApp fx && ax == ay) + = do let (headx, _) = unApply fx + let (heady, _) = unApply fy + -- fail quickly if the heads are disjoint + checkHeads headx heady +-- if True then -- (injective fx || injective fy || fx == fy) then +-- if (injective fx && metavarApp appy) || +-- (injective fy && metavarApp appx) || +-- (injective fx && injective fy) || fx == fy + uplus + (do hf <- un' True bnames fx fy + let ax' = hnormalise hf ctxt env (substNames hf ax) + let ay' = hnormalise hf ctxt env (substNames hf ay) + ha <- un' False bnames ax' ay' + sc 1 + combine bnames hf ha) + (do ha <- un' False bnames ax ay + let fx' = hnormalise ha ctxt env (substNames ha fx) + let fy' = hnormalise ha ctxt env (substNames ha fy) + hf <- un' False bnames fx' fy' + sc 1 + combine bnames hf ha) + | otherwise = -- trace (show (appx, appy, injective fx, metavarApp appy, sameArgStruct appx appy)) $ + do let (headx, argsx) = unApply appx + let (heady, argsy) = unApply appy + -- traceWhen (headx == heady) (show (appx, appy)) $ + uplus ( + if (length argsx == length argsy && + ((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 + failed <- errors + if (not failed) then unArgs uf argsx argsy + else return [] + else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $ + unifyTmpFail appx appy) + (unifyTmpFail appx appy) -- whole application fails + where hnormalise [] _ _ t = 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 _) + | x /= y = unifyFail appx appy + checkHeads (P (DCon _ _) x _) (P (TCon _ _) y _) + = unifyFail appx appy + checkHeads (P (TCon _ _) x _) (P (DCon _ _) y _) + = unifyFail appx appy + checkHeads _ _ = return [] + + unArgs as [] [] = return as + unArgs as (x : xs) (y : ys) + = do let x' = hnormalise as ctxt env (substNames as x) + let y' = hnormalise as ctxt env (substNames as y) + as' <- un' False bnames x' y' + vs <- combine bnames as as' + unArgs vs xs ys + + metavarApp tm = let (f, args) = unApply tm in + metavar f && + all (\x -> metavarApp x) args + && nub args == args + metavarArgs tm = let (f, args) = unApply tm in + all (\x -> metavar x || inenv x) args + && nub args == args + metavarApp' tm = let (f, args) = unApply tm in + all (\x -> pat x || metavar x) (f : args) + && nub args == args + + sameArgStruct appx appy + = let (_, ax) = unApply appx + (_, ay) = unApply appy in + length ax == length ay && + 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 + + rigid (P (DCon _ _) _ _) = True + rigid (P (TCon _ _) _ _) = True + rigid t@(P Ref _ _) = inenv t + rigid (Constant _) = True + rigid (App f a) = rigid f && rigid a + rigid t = not (metavar t) + + metavar t = case t of + 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 + + notFn t = injective t || metavar t || inenv t + + + unifyTmpFail x y + = do UI s f <- get + let r = recoverable x y + let err = CantUnify r + topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s + put (UI s ((topx, topy, env, err) : f)) + return [] + + -- shortcut failure, if we *know* nothing can fix it + unifyFail x y = do UI s f <- get + let r = recoverable x y + let err = CantUnify r + topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s + put (UI s ((topx, topy, env, err) : f)) + lift $ tfail err + + + uB bnames (Let tx vx) (Let ty vy) + = do h1 <- un' False bnames tx ty + h2 <- un' False bnames vx vy + sc 1 + combine bnames h1 h2 + uB bnames (Guess tx vx) (Guess ty vy) + = do h1 <- un' False bnames tx ty + h2 <- un' False bnames vx vy + sc 1 + combine bnames h1 h2 + uB bnames (Lam tx) (Lam ty) = do sc 1; un' False bnames tx ty + uB bnames (Pi tx) (Pi ty) = do sc 1; un' False bnames tx ty + uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty + uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty + uB bnames x y = do UI s f <- get + let r = recoverable (binderTy x) (binderTy y) + let err = CantUnify r topx topy + (CantUnify r (binderTy x) (binderTy y) (Msg "") [] s) + (errEnv env) s + put (UI s ((binderTy x, binderTy y, env, err) : f)) + return [] -- lift $ tfail err + + checkCycle ns p@(x, P _ _ _) = return [p] + checkCycle ns (x, tm) + | not (x `elem` freeNames tm) = checkScope ns (x, tm) + | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) + + checkScope ns (x, tm) = + case boundVs (envPos x 0 env) tm of + [] -> return [(x, tm)] + (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i)) + (inst ns tm) (errEnv env)) + where inst [] tm = tm + inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm) + + combineArgs bnames args = ca [] args where + ca acc [] = return acc + ca acc (x : xs) = do x' <- combine bnames acc x + ca x' xs + + combine bnames as [] = return as + combine bnames as ((n, t) : bs) + = case lookup n as of + Nothing -> combine bnames (as ++ [(n,t)]) bs + Just t' -> do ns <- un' False bnames t t' + -- make sure there's n mapping from n in ns + let ns' = filter (\ (x, _) -> x/=n) ns + sc 1 + combine bnames as (ns' ++ bs) + +boundVs :: Int -> Term -> [Int] +boundVs i (V j) | j <= i = [] + | otherwise = [j] +boundVs i (Bind n b sc) = boundVs (i + 1) sc +boundVs i (App f x) = let fs = boundVs i f + xs = boundVs i x in + nub (fs ++ xs) +boundVs i _ = [] + +envPos x i [] = 0 +envPos x i ((y, _) : ys) | x == y = i + | otherwise = envPos x (i + 1) ys + + +-- If there are any clashes of constructors, deem it unrecoverable, otherwise some +-- more work may help. +-- FIXME: Depending on how overloading gets used, this may cause problems. Better +-- rethink overloading properly... + +recoverable (P (DCon _ _) x _) (P (DCon _ _) y _) + | x == y = True + | otherwise = False +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') + = recoverable f f' -- && recoverable a a' +recoverable f (Bind _ (Pi _) sc) + | (P (DCon _ _) _ _, _) <- unApply f = False + | (P (TCon _ _) _ _, _) <- unApply f = False +recoverable (Bind _ (Pi _) sc) f + | (P (DCon _ _) _ _, _) <- unApply f = False + | (P (TCon _ _) _ _, _) <- unApply f = False +recoverable _ _ = True + +errEnv = map (\(x, b) -> (x, binderTy b)) + +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 + diff --git a/src/Idris/Coverage.hs b/src/Idris/Coverage.hs --- a/src/Idris/Coverage.hs +++ b/src/Idris/Coverage.hs @@ -2,9 +2,9 @@ module Idris.Coverage where -import Core.TT -import Core.Evaluate -import Core.CaseTree +import Idris.Core.TT +import Idris.Core.Evaluate +import Idris.Core.CaseTree import Idris.AbsSyntax import Idris.Delaborate @@ -15,7 +15,7 @@ import Data.Maybe import Debug.Trace -import Control.Monad.State +import Control.Monad.State.Strict mkPatTm :: PTerm -> Idris Term mkPatTm t = do i <- getIState @@ -31,7 +31,7 @@ return $ mkApp t' args' toTT _ = do v <- get put (v + 1) - return (P Bound (MN v "imp") Erased) + return (P Bound (sMN v "imp") Erased) -- 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 @@ -50,20 +50,20 @@ logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args) logLvl 10 $ show argss ++ "\n" ++ show all_args logLvl 10 $ "Original: \n" ++ - showSep "\n" (map (\t -> showImp Nothing True False (delab' i t True True)) xs) + showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs) -- add an infinite supply of explicit arguments to update the possible -- cases for (the return type may be variadic, or function type, sp -- there may be more case splitting that the idris_implicits record -- suggests) let parg = case lookupCtxt n (idris_implicits i) of - (p : _) -> p ++ repeat (PExp 0 False Placeholder "") + (p : _) -> p ++ repeat (PExp 0 [] Placeholder "") _ -> repeat (pexp Placeholder) let tryclauses = mkClauses parg all_args logLvl 2 $ show (length tryclauses) ++ " initially to check" - logLvl 5 $ showSep "\n" (map (showImp Nothing True False) tryclauses) + logLvl 5 $ showSep "\n" (map (showTm i) tryclauses) let new = filter (noMatch i) (nub tryclauses) logLvl 1 $ show (length new) ++ " clauses to check for impossibility" - logLvl 5 $ "New clauses: \n" ++ showSep "\n" (map (showImp Nothing True False) new) + logLvl 5 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new) -- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses) return new -- return (map (\t -> PClause n t [] PImpossible []) new) @@ -164,15 +164,15 @@ otherPats :: PTerm -> [PTerm] otherPats o@(PRef fc n) = ops fc n [] o otherPats o@(PApp _ (PRef fc n) xs) = ops fc n xs o - otherPats o@(PPair fc l r) + otherPats o@(PPair fc _ l r) = ops fc pairCon - ([pimp (UN "A") Placeholder True, - pimp (UN "B") Placeholder True] ++ + ([pimp (sUN "A") Placeholder True, + pimp (sUN "B") Placeholder True] ++ [pexp l, pexp r]) o otherPats o@(PDPair fc t _ v) - = ops fc (UN "Ex_intro") - ([pimp (UN "a") Placeholder True, - pimp (UN "P") Placeholder True] ++ + = ops fc (sUN "Ex_intro") + ([pimp (sUN "a") Placeholder True, + pimp (sUN "P") Placeholder True] ++ [pexp t,pexp v]) o otherPats o@(PConstant c) = return o otherPats arg = return Placeholder @@ -183,7 +183,7 @@ let p = resugar (PApp fc (PRef fc n) (zipWith upd xs' xs)) let tyn = getTy n (tt_ctxt i) case lookupCtxt tyn (idris_datatypes i) of - (TI ns _ _ : _) -> p : map (mkPat fc) (ns \\ [n]) + (TI ns _ _ _ : _) -> p : map (mkPat fc) (ns \\ [n]) _ -> [p] ops fc n arg o = return Placeholder @@ -191,17 +191,14 @@ getExpTm t = getTm t -- put it back to its original form - resugar (PApp _ (PRef fc (UN "Ex_intro")) [_,_,t,v]) + resugar (PApp _ (PRef fc (UN ei)) [_,_,t,v]) + | ei == txt "Ex_intro" = PDPair fc (getTm t) Placeholder (getTm v) resugar (PApp _ (PRef fc n) [_,_,l,r]) | n == pairCon - = PPair fc (getTm l) (getTm r) + = PPair fc IsTerm (getTm l) (getTm r) resugar t = t - getForceable i n = case lookupCtxt n (idris_optimisation i) of - [o] -> forceable o - _ -> [] - dropForce force (x : xs) i | i `elem` force = upd Placeholder x : dropForce force xs (i + 1) dropForce force (x : xs) i = x : dropForce force xs (i + 1) @@ -262,7 +259,8 @@ 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 _ (UN l) _, [_, arg]) <- unApply ap, + l == txt "lazy" = prod n done ok arg | (P nt f _, args) <- unApply ap = do recOK <- checkProdRec (n:done) f let ctxt = tt_ctxt i @@ -291,7 +289,7 @@ cotype (DCon _ _) n ty | (P _ t _, _) <- unApply (getRetTy ty) = case lookupCtxt t (idris_datatypes i) of - [TI _ True _] -> True + [TI _ True _ _] -> True _ -> False cotype nt n ty = False @@ -329,22 +327,23 @@ t' <- case t of Unchecked -> case lookupDef n ctxt of - [CaseOp _ _ _ pats _] -> + [CaseOp _ _ _ _ pats _] -> do t' <- if AssertTotal `elem` opts then return $ Total [] else calcTotality path fc n pats setTotality n t' addIBC (IBCTotal n t') + return t' -- if it's not total, it can't reduce, to keep -- typechecking decidable - case t' of - p@(Partial _) -> - do setAccessibility n Frozen - addIBC (IBCAccess n Frozen) - logLvl 5 $ "HIDDEN: " - ++ show n ++ show p - _ -> return () - return t' +-- case t' of +-- p@(Partial _) -> +-- do setAccessibility n Frozen +-- addIBC (IBCAccess n Frozen) +-- logLvl 5 $ "HIDDEN: " +-- ++ show n ++ show p +-- _ -> return () +-- return t' _ -> return $ Total [] x -> return x case t' of @@ -374,8 +373,19 @@ = do logLvl 2 $ "Checking " ++ show n ++ " for totality" -- buildSCG (fc, n) -- logLvl 2 $ "Built SCG" - checkTotality [] fc n + i <- getIState + t <- checkTotality [] fc n + case t of + -- if it's not total, it can't reduce, to keep + -- typechecking decidable + p@(Partial _) -> do setAccessibility n Frozen + addIBC (IBCAccess n Frozen) + logLvl 5 $ "HIDDEN: " + ++ show n ++ show p + _ -> return () + return t + -- Calculate the size change graph for this definition -- SCG for a function f consists of a list of: @@ -392,7 +402,7 @@ ist <- getIState case lookupCtxt n (idris_callgraph ist) of [cg] -> case lookupDef n (tt_ctxt ist) of - [CaseOp _ _ pats _ cd] -> + [CaseOp _ _ _ pats _ cd] -> let (args, sc) = cases_totcheck cd in do logLvl 2 $ "Building SCG for " ++ show n ++ " from\n" ++ show pats ++ "\n" ++ show sc @@ -408,8 +418,13 @@ findCalls (dePat rhs) (patvars lhs) pargs findCalls ap@(App f a) pvs pargs - | (P _ (UN "lazy") _, [_, arg]) <- unApply ap + | (P _ (UN l) _, [_, arg]) <- unApply ap, + l == txt "lazy" = findCalls arg pvs pargs + -- under a call to "assert_total", don't do any checking, just believe + -- that it is total. + | (P _ (UN at) _, [_, _]) <- unApply ap, + at == txt "assert_total" = [] | (P _ n _, args) <- unApply ap = mkChange n args pargs ++ concatMap (\x -> findCalls x pvs pargs) args @@ -439,6 +454,9 @@ -- find which argument in pargs is smaller than, if any checkSize a (p : ps) i | a == p = Just (i, Same) + | (P _ (UN as) _, [_,arg,_]) <- unApply a, + as == txt "assert_smaller" && arg == p + = Just (i, Smaller) | smaller Nothing a (p, Nothing) = Just (i, Smaller) | otherwise = checkSize a ps (i + 1) checkSize a [] i = Nothing @@ -466,7 +484,7 @@ isInductive (P _ nty _) (P _ nty' _) = let co = case lookupCtxt nty (idris_datatypes ist) of - [TI _ x _] -> x + [TI _ x _ _] -> x _ -> False in nty == nty' && not co isInductive _ _ = False @@ -507,7 +525,7 @@ [ty] = lookupTy n ctxt -- must exist! P _ nty _ = fst (unApply (getRetTy ty)) co = case lookupCtxt nty (idris_datatypes ist) of - [TI _ x _] -> x + [TI _ x _ _] -> x _ -> False args = map snd (getArgTys ty) in map (getRel co nty) (map (fst . unApply . getRetTy) args) diff --git a/src/Idris/DSL.hs b/src/Idris/DSL.hs --- a/src/Idris/DSL.hs +++ b/src/Idris/DSL.hs @@ -5,10 +5,10 @@ import Idris.AbsSyntax import Paths_idris -import Core.TT -import Core.Evaluate +import Idris.Core.TT +import Idris.Core.Evaluate -import Control.Monad.State +import Control.Monad.State.Strict import Debug.Trace debindApp :: SyntaxInfo -> PTerm -> PTerm @@ -37,13 +37,14 @@ expandDo dsl (PCase fc s opts) = PCase fc (expandDo dsl s) (map (pmap (expandDo dsl)) opts) expandDo dsl (PEq fc l r) = PEq fc (expandDo dsl l) (expandDo dsl r) -expandDo dsl (PPair fc l r) = PPair fc (expandDo dsl l) (expandDo dsl r) +expandDo dsl (PPair fc p l r) = PPair fc p (expandDo dsl l) (expandDo dsl r) expandDo dsl (PDPair fc l t r) = PDPair fc (expandDo dsl l) (expandDo dsl t) (expandDo dsl r) expandDo dsl (PAlternative a as) = PAlternative a (map (expandDo dsl) as) expandDo dsl (PHidden t) = PHidden (expandDo dsl t) expandDo dsl (PNoImplicits t) = PNoImplicits (expandDo dsl t) expandDo dsl (PUnifyLog t) = PUnifyLog (expandDo dsl t) +expandDo dsl (PDisamb ns t) = PDisamb ns (expandDo dsl t) expandDo dsl (PReturn fc) = dsl_return dsl expandDo dsl (PRewrite fc r t ty) = PRewrite fc r (expandDo dsl t) ty @@ -57,8 +58,8 @@ block b (DoBind fc n tm : rest) = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))] block b (DoBindP fc p tm : rest) - = PApp fc b [pexp tm, pexp (PLam (MN 0 "bpat") Placeholder - (PCase fc (PRef fc (MN 0 "bpat")) + = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder + (PCase fc (PRef fc (sMN 0 "bpat")) [(p, block b rest)]))] block b (DoLet fc n ty tm : rest) = PLet n ty tm (block b rest) @@ -67,7 +68,7 @@ block b (DoExp fc tm : rest) = PApp fc b [pexp tm, - pexp (PLam (MN 0 "bindx") Placeholder (block b rest))] + pexp (PLam (sMN 0 "bindx") Placeholder (block b rest))] block b _ = PElabError (Msg "Invalid statement in do block") expandDo dsl (PIdiom fc e) = expandDo dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e @@ -92,7 +93,7 @@ v' i (PApp f x as) = PApp f (v' i x) (fmap (fmap (v' i)) as) v' i (PCase f t as) = PCase f (v' i t) (fmap (pmap (v' i)) as) v' i (PEq f l r) = PEq f (v' i l) (v' i r) - v' i (PPair f l r) = PPair f (v' i l) (v' i r) + v' i (PPair f p l r) = PPair f p (v' i l) (v' i r) v' i (PDPair f l t r) = PDPair f (v' i l) (v' i t) (v' i r) v' i (PAlternative a as) = PAlternative a $ map (v' i) as v' i (PHidden t) = PHidden (v' i t) @@ -131,7 +132,7 @@ db' (PAppBind fc t args) = do args' <- dbs args (bs, n) <- get - let nm = MN n ("bindApp" ++ show n) + let nm = sUN ("_bindApp" ++ show n) put ((nm, fc, PApp fc t args') : bs, n+1) return (PRef fc nm) db' (PApp fc t args) @@ -143,9 +144,9 @@ return (PLet n ty v' (debind b sc)) db' (PCase fc s opts) = do s' <- db' s return (PCase fc s' (map (pmap (debind b)) opts)) - db' (PPair fc l r) = do l' <- db' l - r' <- db' r - return (PPair fc l' r') + db' (PPair fc p l r) = do l' <- db' l + r' <- db' r + return (PPair fc p l' r') db' (PDPair fc l t r) = do l' <- db' l r' <- db' r return (PDPair fc l' t r') diff --git a/src/Idris/DataOpts.hs b/src/Idris/DataOpts.hs --- a/src/Idris/DataOpts.hs +++ b/src/Idris/DataOpts.hs @@ -5,79 +5,122 @@ -- Forcing, detagging and collapsing import Idris.AbsSyntax -import Core.TT +import Idris.AbsSyntaxTree +import Idris.Core.TT +import Control.Applicative +import qualified Data.IntMap as M import Data.List import Data.Maybe import Debug.Trace --- Calculate the forceable arguments to a constructor and update the set of --- optimisations +type ForceMap = M.IntMap Forceability -forceArgs :: Name -> Type -> Idris () -forceArgs n t = do i <- getIState - let fargs = force i 0 t - copt <- case lookupCtxt n (idris_optimisation i) of - [] -> return $ Optimise False False [] [] - (op:_) -> return op - let opts = addDef n (copt { forceable = fargs }) (idris_optimisation i) - putIState (i { idris_optimisation = opts }) - addIBC (IBCOpt n) - iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ - show t +-- Calculate the forceable arguments to a constructor +-- and update the set of optimisations. +forceArgs :: Name -> Name -> [Int] -> Type -> Idris () +forceArgs typeName n expforce t = do + ist <- getIState + let fargs = getForcedArgs ist typeName t + copt = case lookupCtxt n (idris_optimisation ist) of + [] -> Optimise False False [] [] + op:_ -> op + opts = addDef n (copt { forceable = M.toList fargs ++ + zip expforce (repeat Unconditional) }) + (idris_optimisation ist) + putIState (ist { idris_optimisation = opts }) + addIBC (IBCOpt n) + iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ show t + +getForcedArgs :: IState -> Name -> Type -> ForceMap +getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t where - force :: IState -> Int -> Term -> [Int] - force ist i (Bind _ (Pi ty) sc) - | collapsibleIn ist ty - = nub $ i : (force ist (i + 1) $ instantiate (P Bound (MN i "?") Erased) sc) - | otherwise = force ist (i + 1) $ instantiate (P Bound (MN i "?") Erased) sc - force _ _ sc@(App f a) - | (_, args) <- unApply sc - = nub $ concatMap guarded args - force _ _ _ = [] + maxUnion = M.unionWith max - collapsibleIn i t - | (P _ tn _, _) <- unApply t - = case lookupCtxt tn (idris_optimisation i) of - [oi] -> collapsible oi - _ -> False - | otherwise = False + -- Label all occurrences of the variable bound in Pi in the rest of + -- the term with the number i so that we can recognize them anytime later. + label i = instantiate $ P Bound (sMN i "ctor_arg") Erased - isF (P _ (MN force "?") _) = Just force - isF _ = Nothing + addCollapsibleArgs :: Int -> Type -> ForceMap -> ForceMap + addCollapsibleArgs i (Bind vn (Pi ty) rest) alreadyForceable + = addCollapsibleArgs (i+1) (label i rest) (forceable $ unApply ty) + where + -- forceable takes an un-applied type of a ctor argument + forceable (P _ tn _, args) + -- if `ty' is collapsible, the argument is unconditionally forceable + | isCollapsible tn + = M.insert i Unconditional alreadyForceable - guarded :: Term -> [Int] - guarded t@(App f a) --- | (P (TCon _ _) _ _, args) <- unApply t --- = mapMaybe isF args ++ concatMap guarded args - | (P (DCon _ _) _ _, args) <- unApply t - = mapMaybe isF args ++ concatMap guarded args - guarded t = mapMaybe isF [t] + -- a recursive occurrence with known indices is conditionally forceable + | tn == typeName + = M.insertWith max i Conditional alreadyForceable --- Calculate whether a collection of constructors is collapsible + forceable _ = alreadyForceable + isCollapsible :: Name -> Bool + isCollapsible n = case lookupCtxt n (idris_optimisation ist) of + [oi] -> collapsible oi + _ -> False + + addCollapsibleArgs _ _ fs = fs + + forcedInTarget :: Int -> Type -> ForceMap + forcedInTarget i (Bind _ (Pi _) rest) = forcedInTarget (i+1) (label i rest) + forcedInTarget i t@(App f a) | (_, as) <- unApply t = unionMap guardedArgs as + forcedInTarget _ _ = M.empty + + guardedArgs :: Term -> ForceMap + guardedArgs t@(App f a) | (P (DCon _ _) _ _, args) <- unApply t + = unionMap bareArg args `maxUnion` unionMap guardedArgs args + guardedArgs t = bareArg t + + bareArg :: Term -> ForceMap + bareArg (P _ (MN i ctor_arg) _) + | ctor_arg == txt "ctor_arg" = M.singleton i Unconditional + bareArg _ = M.empty + + unionMap :: (a -> ForceMap) -> [a] -> ForceMap + unionMap f = M.unionsWith max . map f + +-- Calculate whether a collection of constructors is collapsible +-- and update the state accordingly. collapseCons :: Name -> [(Name, Type)] -> Idris () -collapseCons ty cons = - do i <- getIState - let cons' = map (\ (n, t) -> (n, map snd (getArgTys t))) cons - allFR <- mapM (forceRec i) cons' - if and allFR then detaggable (map getRetTy (map snd cons)) - else checkNewType cons' +collapseCons tn ctors = do + ist <- getIState + case ctors of + _ + | all (ctorCollapsible ist) ctors + , disjointTerms ctorTargetArgs + -> mapM_ setCollapsible (tn : map fst ctors) + + [(cn, ct)] + -> checkNewType ist cn ct + + _ -> return () -- nothing can be done where - -- one constructor; if one remaining argument, treat as newtype - checkNewType [(n, ts)] = do - i <- getIState - case lookupCtxt n (idris_optimisation i) of - (oi:_) -> do let remaining = length ts - length (forceable oi) - if remaining == 1 then - do let oi' = oi { isnewtype = True } - let opts = addDef n oi' (idris_optimisation i) - putIState (i { idris_optimisation = opts }) - else return () - _ -> return () + ctorTargetArgs = map (snd . unApply . getRetTy . snd) ctors - checkNewType _ = return () + ctorArity :: Type -> Int + ctorArity = length . getArgTys + ctorCollapsible :: IState -> (Name, Type) -> Bool + ctorCollapsible ist (n, t) = all (`M.member` forceMap) [0 .. ctorArity t - 1] + where + forceMap = case lookupCtxt n (idris_optimisation ist) of + oi:_ -> M.fromList $ forceable oi + _ -> M.empty + + -- one constructor; if one remaining argument, treat as newtype + checkNewType :: IState -> Name -> Type -> Idris () + checkNewType ist cn ct + | oi:_ <- lookupCtxt cn opt + , length (getArgTys ct) == 1 + forcedCnt (M.fromList $ forceable oi) + = putIState ist{ idris_optimisation = opt' oi } + | otherwise = return () + where + opt = idris_optimisation ist + opt' oi = addDef cn oi{ isnewtype = True } opt + setCollapsible :: Name -> Idris () setCollapsible n = do i <- getIState @@ -91,79 +134,49 @@ putIState (i { idris_optimisation = opts }) addIBC (IBCOpt n) - forceRec :: IState -> (Name, [Type]) -> Idris Bool - forceRec i (n, ts) - = 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 (rtf, rta) = unApply $ getRetTy t - if (ty `elem` freeNames rtf) - then checkFR fs (i+1) xs - else return False - - detaggable :: [Type] -> Idris () - detaggable rtys - = do let rtyArgs = map (snd . unApply) rtys - -- if every rtyArgs is disjoint with every other, it's detaggable, - -- therefore also collapsible given forceable/recursive check - if disjoint rtyArgs - then mapM_ setCollapsible (ty : map fst cons) - else return () - - disjoint :: [[Term]] -> Bool - disjoint [] = True - disjoint [x] = True - disjoint (x : xs) = anyDisjoint x xs && disjoint xs - - anyDisjoint x [] = True - anyDisjoint x (y : ys) = disjointCons x y - - disjointCons [] [] = False - disjointCons [] y = False - disjointCons x [] = False - disjointCons (x : xs) (y : ys) - = disjointCon x y || disjointCons xs ys + disjointTerms :: [[Term]] -> Bool + disjointTerms [] = True + disjointTerms [xs] = True + disjointTerms (xs : xss) = + -- xs is disjoint with every pattern from xss + all (or . zipWith disjoint xs) xss + -- and xss is pairwise disjoint, too + && disjointTerms xss - disjointCon x y = let (cx, _) = unApply x - (cy, _) = unApply y in - case (cx, cy) of - (P (DCon _ _) nx _, P (DCon _ _) ny _) -> nx /= ny - _ -> False + -- Return True if the two patterns are provably disjoint. + -- Return False if they're not or if unsure. + disjoint :: Term -> Term -> Bool + disjoint x y = case (cx, cy) of + -- data constructors -> compare their names + (P (DCon _ _) nx _, P (DCon _ _) ny _) + | nx /= ny -> True + | otherwise -> or $ zipWith disjoint xargs yargs + _ -> False + where + (cx, xargs) = unApply x + (cy, yargs) = unApply y class Optimisable term where applyOpts :: term -> Idris term stripCollapsed :: term -> Idris term instance (Optimisable a, Optimisable b) => Optimisable (a, b) where - applyOpts (x, y) = do x' <- applyOpts x - y' <- applyOpts y - return (x', y') - stripCollapsed (x, y) = do x' <- stripCollapsed x - y' <- stripCollapsed y - return (x', y') - + applyOpts (x, y) = (,) <$> applyOpts x <*> applyOpts y + stripCollapsed (x, y) = (,) <$> stripCollapsed x <*> stripCollapsed y instance (Optimisable a, Optimisable b) => Optimisable (vs, a, b) where - applyOpts (v, x, y) = do x' <- applyOpts x - y' <- applyOpts y - return (v, x', y') - stripCollapsed (v, x, y) = do x' <- stripCollapsed x - y' <- stripCollapsed y - return (v, x', y') + applyOpts (v, x, y) = (,,) v <$> applyOpts x <*> applyOpts y + stripCollapsed (v, x, y) = (,,) v <$> stripCollapsed x <*> stripCollapsed y instance Optimisable a => Optimisable [a] where applyOpts = mapM applyOpts stripCollapsed = mapM stripCollapsed instance Optimisable a => Optimisable (Either a (a, a)) where - applyOpts (Left t) = do t' <- applyOpts t; return $ Left t' - applyOpts (Right t) = do t' <- applyOpts t; return $ Right t' - stripCollapsed (Left t) = do t' <- stripCollapsed t; return $ Left t' - stripCollapsed (Right t) = do t' <- stripCollapsed t; return $ Right t' + applyOpts (Left t) = Left <$> applyOpts t + applyOpts (Right t) = Right <$> applyOpts t + stripCollapsed (Left t) = Left <$> stripCollapsed t + stripCollapsed (Right t) = Right <$> stripCollapsed t -- Raw is for compile time optimisation (before type checking) -- Term is for run time optimisation (after type checking, collapsing allowed) @@ -175,55 +188,66 @@ | (Var n, args) <- raw_unapply t -- MAGIC HERE = do args' <- mapM applyOpts args i <- getIState - case lookupCtxt n (idris_optimisation i) of - (oi:_) -> return $ applyDataOpt oi n args' - _ -> return (raw_apply (Var n) args') - | otherwise = do f' <- applyOpts f - a' <- applyOpts a - return (RApp f' a') - applyOpts (RBind n b t) = do b' <- applyOpts b - t' <- applyOpts t - return (RBind n b' t') - applyOpts (RForce t) = applyOpts t + return $ case lookupCtxt n (idris_optimisation i) of + oi:_ -> applyDataOpt oi n args' + _ -> raw_apply (Var n) args' + | otherwise = RApp <$> applyOpts f <*> applyOpts a + + applyOpts (RBind n b t) = RBind n <$> applyOpts b <*> applyOpts t + applyOpts (RForce t) = applyOpts t applyOpts t = return t stripCollapsed t = return t -instance Optimisable t => Optimisable (Binder t) where - applyOpts (Let t v) = do t' <- applyOpts t - v' <- applyOpts v - return (Let t' v') +-- Erase types (makes ibc smaller, and we don't need them) +instance Optimisable (Binder (TT Name)) where + applyOpts (Let t v) = Let <$> return Erased <*> applyOpts v + applyOpts b = return (b { binderTy = Erased }) + stripCollapsed (Let t v) = Let <$> return Erased <*> stripCollapsed v + stripCollapsed b = return (b { binderTy = Erased }) + +instance Optimisable (Binder Raw) where applyOpts b = do t' <- applyOpts (binderTy b) return (b { binderTy = t' }) - stripCollapsed (Let t v) = do t' <- stripCollapsed t - v' <- stripCollapsed v - return (Let t' v') + stripCollapsed (Let t v) = Let <$> stripCollapsed t <*> stripCollapsed v stripCollapsed b = do t' <- stripCollapsed (binderTy b) return (b { binderTy = t' }) +forcedArgSeq :: OptInfo -> [Maybe Forceability] +forcedArgSeq oi = map (\i -> M.lookup i forceMap) [0..] + where + forceMap = M.fromList $ forceable oi +forcedCnt :: ForceMap -> Int +forcedCnt = length . filter (== Unconditional) . M.elems + applyDataOpt :: OptInfo -> Name -> [Raw] -> Raw -applyDataOpt oi n args - = let args' = zipWith doForce (map (\x -> x `elem` (forceable oi)) [0..]) - args in - raw_apply (Var n) args' +applyDataOpt oi n args + = raw_apply (Var n) $ zipWith doForce (forcedArgSeq oi) args where - doForce True a = RForce a - doForce False a = a + doForce (Just Unconditional) a = RForce a + doForce _ a = a -- Run-time: do everything +prel = [txt "Nat", txt "Prelude"] + instance Optimisable (TT Name) where - applyOpts (P _ (NS (UN "plus") ["Nat","Prelude"]) _) - = return (P Ref (UN "prim__addBigInt") Erased) - applyOpts (P _ (NS (UN "mult") ["Nat","Prelude"]) _) - = return (P Ref (UN "prim__mulBigInt") Erased) - applyOpts (App (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _) x) + applyOpts (P _ (NS (UN fn) mod) _) + | fn == txt "plus" && mod == prel + = return (P Ref (sUN "prim__addBigInt") Erased) + applyOpts (P _ (NS (UN fn) mod) _) + | fn == txt "mult" && mod == prel + = return (P Ref (sUN "prim__mulBigInt") Erased) + applyOpts (App (P _ (NS (UN fn) mod) _) x) + | fn == txt "fromIntegerNat" && mod == prel = applyOpts x - applyOpts (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _) - = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased) - applyOpts (P _ (NS (UN "toIntegerNat") ["Nat","Prelude"]) _) - = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased) + applyOpts (P _ (NS (UN fn) mod) _) + | fn == txt "fromIntegerNat" && mod == prel + = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased) + applyOpts (P _ (NS (UN fn) mod) _) + | fn == txt "toIntegerNat" && mod == prel + = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased) applyOpts c@(P (DCon t arity) n _) = do i <- getIState case lookupCtxt n (idris_optimisation i) of @@ -268,35 +292,33 @@ applyDataOptRT :: OptInfo -> Name -> Int -> Int -> [Term] -> Term applyDataOptRT oi n tag arity args - | length args == arity = doOpts n args (collapsible oi) (forceable oi) + | length args == arity = doOpts n args (collapsible oi) (M.fromList $ forceable oi) | otherwise = let extra = satArgs (arity - length args) tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra) - (collapsible oi) (forceable oi) in + (collapsible oi) (M.fromList $ forceable oi) in bind extra tm where - satArgs n = map (\i -> MN i "sat") [1..n] + satArgs n = map (\i -> sMN i "sat") [1..n] bind [] tm = tm bind (n:ns) tm = Bind n (Lam Erased) (pToV n (bind ns tm)) -- Nat special cases -- TODO: Would be nice if this was configurable in idris source! - doOpts (NS (UN "Z") ["Nat", "Prelude"]) [] _ _ = Constant (BI 0) - doOpts (NS (UN "S") ["Nat", "Prelude"]) [k] _ _ - = App (App (P Ref (UN "prim__addBigInt") Erased) k) (Constant (BI 1)) - - doOpts n args True f = Erased - doOpts n args _ forced - = let args' = filter keep (zip (map (\x -> x `elem` forced) [0..]) - args) in - if isnewtype oi - then case args' of - [(_, val)] -> val - _ -> error "Can't happen (not isnewtype)" - else - mkApp (P (DCon tag (arity - length forced)) n Erased) - (map snd args') - - keep (forced, _) = not forced + doOpts (NS (UN z) [nat, prelude]) [] _ _ + | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude" + = Constant (BI 0) + doOpts (NS (UN s) [nat, prelude]) [k] _ _ + | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude" + = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1)) + doOpts n args True _ = Erased + doOpts n args _ forceMap + | isnewtype oi = case args' of + [val] -> val + _ -> error $ "Can't happen (newtype not a singleton): " ++ show args' + | otherwise = mkApp ctor' args' + where + ctor' = (P (DCon tag (arity - forcedCnt forceMap)) n Erased) + args' = [t | (f, t) <- zip (forcedArgSeq oi) args, f /= Just Unconditional] diff --git a/src/Idris/DeepSeq.hs b/src/Idris/DeepSeq.hs --- a/src/Idris/DeepSeq.hs +++ b/src/Idris/DeepSeq.hs @@ -1,37 +1,16 @@ -module Idris.DeepSeq where +module Idris.DeepSeq(module Idris.DeepSeq, module Idris.Core.DeepSeq) where -import Core.TT -import Idris.AbsSyntax +import Idris.Core.DeepSeq +import Idris.Core.TT +import Idris.AbsSyntaxTree import Control.DeepSeq -- All generated by 'derive' -instance NFData Raw where - rnf (Var x1) = rnf x1 `seq` () - rnf (RBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () - rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf RType = () - rnf (RForce x1) = rnf x1 `seq` () - rnf (RConstant x1) = x1 `seq` () - -instance NFData FC where - rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () - -instance NFData Name where - rnf (UN x1) = rnf x1 `seq` () - rnf (NS x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf NErased = () - rnf (SN x1) = rnf x1 `seq` () - -instance NFData SpecialName where - rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () - rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (MethodN x1) = rnf x1 `seq` () - rnf (CaseN x1) = rnf x1 `seq` () - rnf (ElimN x1) = rnf x1 `seq` () +instance NFData Forceability where + rnf Conditional = () + rnf Unconditional = () instance NFData IntTy where rnf (ITFixed x1) = rnf x1 `seq` () @@ -40,85 +19,16 @@ rnf ITChar = () rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` () - instance NFData NativeTy where rnf IT8 = () rnf IT16 = () rnf IT32 = () rnf IT64 = () - instance NFData ArithTy where rnf (ATInt x1) = rnf x1 `seq` () rnf ATFloat = () -instance NFData Err where - rnf (Msg x1) = rnf x1 `seq` () - rnf (InternalMsg x1) = rnf x1 `seq` () - rnf (CantUnify x1 x2 x3 x4 x5 x6) - = rnf x1 `seq` - rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () - rnf (InfiniteUnify x1 x2 x3) - = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () - rnf (CantConvert x1 x2 x3) - = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () - rnf (UnifyScope x1 x2 x3 x4) - = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () - rnf (CantInferType x1) = rnf x1 `seq` () - rnf (NonFunctionType x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (CantIntroduce x1) = rnf x1 `seq` () - rnf (NoSuchVariable x1) = rnf x1 `seq` () - rnf (NoTypeDecl x1) = rnf x1 `seq` () - rnf (NotInjective x1 x2 x3) - = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () - rnf (CantResolve x1) = rnf x1 `seq` () - rnf (CantResolveAlts x1) = rnf x1 `seq` () - rnf (IncompleteTerm x1) = rnf x1 `seq` () - rnf UniverseError = () - rnf ProgramLineComment = () - rnf (Inaccessible x1) = rnf x1 `seq` () - rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` () - rnf (AlreadyDefined x1) = rnf x1 `seq` () - rnf (ProofSearchFail x1) = rnf x1 `seq` () - rnf (NoRewriting x1) = rnf x1 `seq` () - rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (Elaborating x1 x2 x3) - = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () - rnf (ProviderError x1) = rnf x1 `seq` () - rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` () - -instance (NFData b) => NFData (Binder b) where - rnf (Lam x1) = rnf x1 `seq` () - rnf (Pi x1) = rnf x1 `seq` () - rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (Hole x1) = rnf x1 `seq` () - rnf (GHole x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (Guess x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (PVar x1) = rnf x1 `seq` () - rnf (PVTy x1) = rnf x1 `seq` () - -instance NFData UExp where - rnf (UVar x1) = rnf x1 `seq` () - rnf (UVal x1) = rnf x1 `seq` () - -instance NFData NameType where - rnf Bound = () - rnf Ref = () - rnf (DCon x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` () - -instance (NFData n) => NFData (TT n) where - rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () - rnf (V x1) = rnf x1 `seq` () - rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () - rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (Constant x1) = x1 `seq` () - rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf Erased = () - rnf Impossible = () - rnf (TType x1) = rnf x1 `seq` () - instance NFData SizeChange where rnf Smaller = () rnf Same = () @@ -143,6 +53,9 @@ rnf Static = () rnf Dynamic = () +instance NFData ArgOpt where + rnf _ = () + instance NFData Plicity where rnf (Imp x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () @@ -209,6 +122,9 @@ rnf (PTransform x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () +instance NFData PunInfo where + rnf x = x `seq` () + instance (NFData t) => NFData (PClause' t) where rnf (PClause x1 x2 x3 x4 x5 x6) = rnf x1 `seq` @@ -241,14 +157,14 @@ rnf (PAppBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (PMatchApp x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PCase x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () - rnf (PTrue x1) = rnf x1 `seq` () + rnf (PTrue x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PFalse x1) = rnf x1 `seq` () rnf (PRefl x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PResolveTC x1) = rnf x1 `seq` () rnf (PEq x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (PRewrite x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () - rnf (PPair x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PPair x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () rnf (PDPair x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () rnf (PAlternative x1 x2) = rnf x1 `seq` rnf x2 `seq` () @@ -276,6 +192,7 @@ rnf (Focus x1) = rnf x1 `seq` () rnf (Refine x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (Rewrite x1) = rnf x1 `seq` () + rnf (Induction x1) = rnf x1 `seq` () rnf (Equiv x1) = rnf x1 `seq` () rnf (MatchRefine x1) = rnf x1 `seq` () rnf (LetTac x1 x2) = rnf x1 `seq` rnf x2 `seq` () @@ -320,16 +237,16 @@ rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () instance NFData ClassInfo where - rnf (CI x1 x2 x3 x4 x5) + rnf (CI x1 x2 x3 x4 x5 x6) = rnf x1 `seq` - rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` () + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () instance NFData OptInfo where rnf (Optimise x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () instance NFData TypeInfo where - rnf (TI x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (TI x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () instance (NFData t) => NFData (DSL' t) where rnf (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9) diff --git a/src/Idris/Delaborate.hs b/src/Idris/Delaborate.hs --- a/src/Idris/Delaborate.hs +++ b/src/Idris/Delaborate.hs @@ -1,14 +1,19 @@ {-# LANGUAGE PatternGuards #-} -module Idris.Delaborate where +module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', pshow, pprintErr) where -- Convert core TT back into high level syntax, primarily for display -- purposes. +import Util.Pretty + import Idris.AbsSyntax -import Core.TT -import Core.Evaluate +import Idris.Core.TT +import Idris.Core.Evaluate +import Idris.ErrReverse +import Data.List (intersperse) + import Debug.Trace bugaddr = "https://github.com/idris-lang/Idris-dev/issues" @@ -30,7 +35,7 @@ delab' i t f mvs = delabTy' i [] t f mvs delabTy' :: IState -> [PArg] -- ^ implicit arguments to type, if any - -> Term + -> Term -> Bool -- ^ use full names -> Bool -- ^ Don't treat metavariables specially -> PTerm @@ -40,15 +45,15 @@ 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 + | otherwise = PRef un (sUN ("v" ++ show i ++ "")) + de env _ (P _ n _) | n == unitTy = PTrue un IsType + | n == unitCon = PTrue un IsTerm | n == falseTy = PFalse un | Just n' <- lookup n env = PRef un n' | otherwise = case lookup n (idris_metavars ist) of - Just (Just _, mi, _) -> mkMVApp (dens n) [] - _ -> PRef un (dens n) + Just (Just _, mi, _) -> mkMVApp n [] + _ -> PRef un 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) @@ -61,8 +66,8 @@ = 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 (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc + de env _ (Bind n (Guess ty val) sc) = de ((n, sUN "[__]"):env) [] sc de env _ (Bind n _ sc) = de ((n,n):env) [] sc de env _ (Constant i) = PConstant i de env _ Erased = Placeholder @@ -78,24 +83,24 @@ 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 == pairTy = PPair un IsType (de env [] l) (de env [] r) | n == eqCon = PRefl un (de env [] r) - | n == UN "lazy" = de env [] r + | n == sUN "lazy" = de env [] r deFn env (P _ n _) [ty, Bind x (Lam _) r] - | n == UN "Exists" + | n == sUN "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 == pairCon = PPair un IsTerm (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) + | n == sUN "Ex_intro" = PDPair un (de env [] l) Placeholder + (de env [] r) deFn env (P _ n _) args | not mvs = case lookup n (idris_metavars ist) of Just (Just _, mi, _) -> - mkMVApp (dens n) (drop mi (map (de env []) args)) - _ -> mkPApp (dens n) (map (de env []) args) - | otherwise = mkPApp (dens n) (map (de env []) args) + mkMVApp n (drop mi (map (de env []) args)) + _ -> mkPApp n (map (de env []) args) + | otherwise = mkPApp n (map (de env []) args) deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args)) mkMVApp n [] @@ -112,80 +117,115 @@ imp (PConstraint p l _ d) arg = PConstraint p l arg d imp (PTacImplicit p l n sc _ d) arg = PTacImplicit p l n sc arg d +-- | How far to indent sub-errors +errorIndent :: Int +errorIndent = 8 -indented text = boxIt '\n' $ unlines $ map ('\t':) $ lines text where - boxIt c text = (c:text) ++ if last text == c - then "" - else [c] +-- | Actually indent a sub-error - no line at end because a newline can end +-- multiple layers of indent +indented :: Doc a -> Doc a +indented = nest errorIndent . (line <>) +pprintTerm :: IState -> PTerm -> Doc OutputAnnotation +pprintTerm ist = prettyImp (opt_showimp (idris_options ist)) + pshow :: IState -> Err -> String -pshow i (Msg s) = s -pshow i (InternalMsg s) = "INTERNAL ERROR: " ++ show s ++ - "\nThis is probably a bug, or a missing error message.\n" ++ - "Please consider reporting at " ++ bugaddr -pshow i (CantUnify _ x y e sc s) - = let imps = opt_showimp (idris_options i) in - let colour = idris_colourRepl i in - "Can't unify" ++ indented (showImp (Just i) imps colour (delab i x)) - ++ "with" ++ indented (showImp (Just i) imps colour (delab i y)) ++ --- " (" ++ show x ++ " and " ++ show y ++ ") " ++ - case e of - Msg "" -> "" - _ -> "\nSpecifically:" ++ - indented (pshow i e) ++ - if (opt_errContext (idris_options i)) then showSc i sc else "" -pshow i (CantConvert x y env) - = let imps = opt_showimp (idris_options i) in - let colour = idris_colourRepl i in - "Can't convert" ++ indented (showImp (Just i) imps colour (delab i x)) ++ "with" - ++ indented (showImp (Just i) imps colour (delab i y)) ++ - if (opt_errContext (idris_options i)) then showSc i env else "" -pshow i (UnifyScope n out tm env) - = let imps = opt_showimp (idris_options i) in - let colour = idris_colourRepl i in - "Can't unify" ++ indented (show n) ++ "with" - ++ indented (showImp (Just i) imps colour (delab i tm)) ++ "as" ++ - indented (show out) ++ "is not in scope" ++ - if (opt_errContext (idris_options i)) then showSc i env else "" -pshow i (CantInferType t) - = "Can't infer type for " ++ t -pshow i (NonFunctionType f ty) - = let imps = opt_showimp (idris_options i) in - let colour = idris_colourRepl i in - showImp (Just i) imps colour (delab i f) ++ " does not have a function type (" - ++ showImp (Just i) imps colour (delab i ty) ++ ")" -pshow i (TooManyArguments f) - = "Too many arguments for " ++ show f -pshow i (CantIntroduce ty) - = let imps = opt_showimp (idris_options i) in - let colour = idris_colourRepl i in - "Can't use lambda here: type is " ++ showImp (Just i) imps colour (delab i ty) -pshow i (InfiniteUnify x tm env) - = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++ - " would lead to infinite value" ++ - if (opt_errContext (idris_options i)) then showSc i env else "" -pshow i (NotInjective p x y) = "Can't verify injectivity of " ++ show (delab i p) ++ - " when unifying " ++ show (delab i x) ++ " and " ++ - show (delab i y) -pshow i (CantResolve c) = "Can't resolve type class " ++ show (delab i c) -pshow i (CantResolveAlts as) = "Can't disambiguate name: " ++ showSep ", " as -pshow i (NoTypeDecl n) = "No type declaration for " ++ show n -pshow i (NoSuchVariable n) = "No such variable " ++ show n -pshow i (IncompleteTerm t) = "Incomplete term " ++ showImp Nothing True False (delab i t) -pshow i UniverseError = "Universe inconsistency" -pshow i ProgramLineComment = "Program line next to comment" -pshow i (Inaccessible n) = show n ++ " is not an accessible pattern variable" -pshow i (NonCollapsiblePostulate n) - = "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 (Elaborating s n e) = "When elaborating " ++ s ++ - showqual i n ++ ":\n" ++ pshow i e -pshow i (ProviderError msg) = "Type provider error: " ++ msg -pshow i (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: " ++ pshow i e +pshow ist err = displayDecorated (consoleDecorate ist) . + renderPretty 1.0 80 . + fmap (fancifyAnnots ist) $ pprintErr ist err +pprintErr :: IState -> Err -> Doc OutputAnnotation +pprintErr i err = pprintErr' i (fmap (errReverse i) err) + +pprintErr' i (Msg s) = text s +pprintErr' i (InternalMsg s) = + vsep [ text "INTERNAL ERROR:" <+> text s, + text "This is probably a bug, or a missing error message.", + text ("Please consider reporting at " ++ bugaddr) + ] +pprintErr' i (CantUnify _ x y e sc s) = + text "Can't unify" <> indented (pprintTerm i (delab i x)) <$> + text "with" <> indented (pprintTerm i (delab i y)) <> + case e of + Msg "" -> empty + _ -> line <> line <> text "Specifically:" <> + indented (pprintErr' i e) <> + if (opt_errContext (idris_options i)) then text $ showSc i sc else empty +pprintErr' i (CantConvert x y env) = + text "Can't convert" <> indented (pprintTerm i (delab i x)) <$> + text "with" <> indented (pprintTerm i (delab i y)) <> + if (opt_errContext (idris_options i)) then line <> text (showSc i env) else empty +pprintErr' i (CantSolveGoal x env) = + text "Can't solve goal " <> indented (pprintTerm i (delab i x)) <> + if (opt_errContext (idris_options i)) then line <> text (showSc i env) else empty +pprintErr' i (UnifyScope n out tm env) = + text "Can't unify" <> indented (annName n) <+> + text "with" <> indented (pprintTerm i (delab i tm)) <+> + text "as" <> indented (annName out) <> text "is not in scope" <> + if (opt_errContext (idris_options i)) then line <> text (showSc i env) else empty +pprintErr' i (CantInferType t) = text "Can't infer type for" <+> text t +pprintErr' i (NonFunctionType f ty) = + pprintTerm i (delab i f) <+> + text "does not have a function type" <+> + parens (pprintTerm i (delab i ty)) +pprintErr' i (NotEquality tm ty) = + pprintTerm i (delab i tm) <+> + text "does not have an equality type" <+> + parens (pprintTerm i (delab i ty)) +pprintErr' i (TooManyArguments f) = text "Too many arguments for" <+> annName f +pprintErr' i (CantIntroduce ty) = + text "Can't use lambda here: type is" <+> pprintTerm i (delab i ty) +pprintErr' i (InfiniteUnify x tm env) = + text "Unifying" <+> annName' x (showbasic x) <+> text "and" <+> pprintTerm i (delab i tm) <+> + text "would lead to infinite value" <> + if (opt_errContext (idris_options i)) then line <> text (showSc i env) else empty +pprintErr' i (NotInjective p x y) = + text "Can't verify injectivity of" <+> pprintTerm i (delab i p) <+> + text " when unifying" <+> pprintTerm i (delab i x) <+> text "and" <+> + pprintTerm i (delab i y) +pprintErr' i (CantResolve c) = text "Can't resolve type class" <+> pprintTerm i (delab i c) +pprintErr' i (CantResolveAlts as) = text "Can't disambiguate name:" <+> + cat (punctuate (comma <> space) (map text as)) +pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n +pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n +pprintErr' i (IncompleteTerm t) = text "Incomplete term" <+> pprintTerm i (delab i t) +pprintErr' i UniverseError = text "Universe inconsistency" +pprintErr' i ProgramLineComment = text "Program line next to comment" +pprintErr' i (Inaccessible n) = annName n <+> text "is not an accessible pattern variable" +pprintErr' i (NonCollapsiblePostulate n) = text "The return type of postulate" <+> + annName n <+> text "is not collapsible" +pprintErr' i (AlreadyDefined n) = annName n<+> + text "is already defined" +pprintErr' i (ProofSearchFail e) = pprintErr' i e +pprintErr' i (NoRewriting tm) = text "rewrite did not change type" <+> pprintTerm i (delab i tm) +pprintErr' i (At f e) = annotate (AnnFC f) (text (show f)) <> colon <> pprintErr' i e +pprintErr' i (Elaborating s n e) = text "When elaborating" <+> text s <> + annName' n (showqual i n) <> colon <$> + pprintErr' i e +pprintErr' i (ProviderError msg) = text ("Type provider error: " ++ msg) +pprintErr' i (LoadingFailed fn e) = text "Loading" <+> text fn <+> text "failed:" <+> pprintErr' i e +pprintErr' i (ReflectionError parts orig) = + let parts' = map (hsep . map showPart) parts in + vsep parts' <> + if (opt_origerr (idris_options i)) + then line <> line <> text "Original error:" <$> indented (pprintErr' i orig) + else empty + where showPart :: ErrorReportPart -> Doc OutputAnnotation + showPart (TextPart str) = text str + showPart (NamePart n) = annName n + showPart (TermPart tm) = pprintTerm i (delab i tm) + showPart (SubReport rs) = indented . hsep . map showPart $ rs +pprintErr' i (ReflectionFailed msg err) = + text "When attempting to perform error reflection, the following internal error occurred:" <> + indented (pprintErr' i err) <> + text ("This is probably a bug. Please consider reporting it at " ++ bugaddr) + +annName :: Name -> Doc OutputAnnotation +annName n = annName' n (show n) + +annName' :: Name -> String -> Doc OutputAnnotation +annName' n str = annotate (AnnName n Nothing Nothing) (text str) + showSc i [] = "" showSc i xs = "\n\nIn context:\n" ++ showSep "\n" (map showVar (reverse xs)) where showVar (x, y) = "\t" ++ showbasic x ++ " : " ++ show (delab i y) @@ -199,8 +239,8 @@ dens n = n showbasic n@(UN _) = show n -showbasic (MN _ s) = s -showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n +showbasic (MN _ s) = str s +showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n showbasic (SN s) = show s diff --git a/src/Idris/Docs.hs b/src/Idris/Docs.hs --- a/src/Idris/Docs.hs +++ b/src/Idris/Docs.hs @@ -3,8 +3,8 @@ import Idris.AbsSyntax import Idris.AbsSyntaxTree import Idris.Delaborate -import Core.TT -import Core.Evaluate +import Idris.Core.TT +import Idris.Core.Evaluate import Data.Maybe import Data.List @@ -107,7 +107,7 @@ return (Doc n docstr args (delab i ty) f) where funName :: Name -> String - funName (UN n) = n + funName (UN n) = str n funName (NS n _) = funName n diff --git a/src/Idris/ElabDecls.hs b/src/Idris/ElabDecls.hs --- a/src/Idris/ElabDecls.hs +++ b/src/Idris/ElabDecls.hs @@ -19,21 +19,22 @@ import IRTS.Lang import Paths_idris -import Core.TT -import Core.Elaborate hiding (Tactic(..)) -import Core.Evaluate -import Core.Execute -import Core.Typecheck -import Core.CaseTree +import Idris.Core.TT +import Idris.Core.Elaborate hiding (Tactic(..)) +import Idris.Core.Evaluate +import Idris.Core.Execute +import Idris.Core.Typecheck +import Idris.Core.CaseTree import Control.DeepSeq import Control.Monad -import Control.Monad.State +import Control.Monad.State.Strict as State import Data.List import Data.Maybe import Debug.Trace import qualified Data.Map as Map +import qualified Data.Text as T import Data.Char(isLetter, toLower) import Data.List.Split (splitOn) @@ -66,15 +67,15 @@ ctxt <- getContext i <- getIState - logLvl 3 $ show n ++ " pre-type " ++ showImp Nothing True False ty' + logLvl 3 $ show n ++ " pre-type " ++ showTmImpls ty' ty' <- addUsingConstraints syn fc ty' ty' <- implicit syn n ty' let ty = addImpl i ty' - logLvl 2 $ show n ++ " type " ++ showImp Nothing True False ty + logLvl 2 $ show n ++ " type " ++ showTmImpls ty ((tyT, defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] - (errAt "type of " n (erun fc (build i info False n ty))) + (errAt "type of " n (erun fc (build i info False [] n ty))) ds <- checkDef fc defer let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds addDeferred ds' @@ -91,13 +92,15 @@ let nty' = normalise ctxt [] nty -- Add normalised type to internals - addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')) - addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))) + rep <- useREPL + when rep $ do + addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')) + addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))) let (t, _) = unApply (getRetTy nty') let corec = case t of P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of - [TI _ True _] -> True + [TI _ True _ _] -> True _ -> False _ -> False let opts' = if corec then (Coinductive : opts) else opts @@ -112,6 +115,20 @@ addIBC (IBCFlags n opts') when (Implicit `elem` opts) $ do addCoercion n addIBC (IBCCoercion n) + -- If the function is declared as an error handler and the language + -- extension is enabled, then add it to the list of error handlers. + errorReflection <- fmap (elem ErrorReflection . idris_language_extensions) getIState + when (ErrorHandler `elem` opts) $ do + if errorReflection + then + -- TODO: Check that the declared type is the correct type for an error handler: + -- handler : List (TTName, TT) -> Err -> ErrorReport - for now no ctxt + if tyIsHandler nty' + then do i <- getIState + putIState $ i { idris_errorhandlers = idris_errorhandlers i ++ [n] } + addIBC (IBCErrorHandler n) + else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler" + else ifail "Error handlers can only be defined when the ErrorReflection language extension is enabled." when corec $ do setAccessibility n Frozen addIBC (IBCAccess n Frozen) return usety @@ -124,7 +141,23 @@ | otherwise = mergeTy sc sc' mergeTy _ sc = sc + err = txt "Err" + maybe = txt "Maybe" + lst = txt "List" + errrep = txt "ErrorReportPart" + tyIsHandler (Bind _ (Pi (P _ (NS (UN e) ns1) _)) + (App (P _ (NS (UN m) ns2) _) + (App (P _ (NS (UN l) ns3) _) + (P _ (NS (UN r) ns4) _)))) + | e == err && m == maybe && l == lst && r == errrep + , ns1 == map txt ["Errors","Reflection","Language"] + , ns2 == map txt ["Maybe", "Prelude"] + , ns3 == map txt ["List", "Prelude"] + , ns4 == map txt ["Errors","Reflection","Language"] = True + tyIsHandler _ = False + + elabPostulate :: ElabInfo -> SyntaxInfo -> String -> FC -> FnOpts -> Name -> PTerm -> Idris () elabPostulate info syn doc fc opts n ty @@ -159,7 +192,7 @@ t_in <- implicit syn n t_in let t = addImpl i t_in ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] - (erun fc (build i info False n t)) + (erun fc (build i info False [] n t)) def' <- checkDef fc defer let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def' addDeferredTyCon def'' @@ -178,7 +211,7 @@ let t = addImpl i t_in ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] - (errAt "data declaration " n (erun fc (build i info False n t))) + (errAt "data declaration " n (erun fc (build i info False [] n t))) def' <- checkDef fc defer let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def' -- if n is defined already, make sure it is just a type declaration @@ -196,14 +229,18 @@ let as = map (const Nothing) (getArgTys cty) let params = findParams (map snd cons) logLvl 2 $ "Parameters : " ++ show params - putIState (i { idris_datatypes = addDef n (TI (map fst cons) codata params) + putIState (i { idris_datatypes = + addDef n (TI (map fst cons) codata opts params) (idris_datatypes i) }) addIBC (IBCDef n) addIBC (IBCData n) addDocStr n doc addIBC (IBCDoc n) + let metainf = DataMI params + addIBC (IBCMetaInformation n metainf) collapseCons n cons updateContext (addDatatype (Data n ttag cty cons)) + updateContext (setMetaInformation n metainf) mapM_ (checkPositive n) cons if DefaultEliminator `elem` opts then evalStateT (elabEliminator params n t dcons info) Map.empty else return () @@ -269,7 +306,8 @@ type EliminatorState = StateT (Map.Map String Int) Idris -- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite -elabEliminator :: [Int] -> Name -> PTerm -> [(String, Name, PTerm, FC)] -> ElabInfo -> EliminatorState () +elabEliminator :: [Int] -> Name -> PTerm -> [(String, Name, PTerm, FC, [Name])] -> + ElabInfo -> EliminatorState () elabEliminator paramPos n ty cons info = do elimLog $ "Elaborating eliminator" let (cnstrs, _) = splitPi ty @@ -277,7 +315,7 @@ generalParams <- namePis False pms motiveIdxs <- namePis False idxs let motive = mkMotive n paramPos generalParams motiveIdxs - consTerms <- mapM (\(c@(_,cnm,_,_)) -> do + consTerms <- mapM (\(c@(_,cnm,_,_,_)) -> do name <- freshName $ "elim_" ++ simpleName cnm consTerm <- extractConsTerm c generalParams return (name, expl, consTerm)) cons @@ -289,17 +327,17 @@ let clauseConsElimArgs = map getPiName consTerms let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs let clauseGeneralArgs = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs' - let elimSig = "-- eliminator signature: " ++ showImp Nothing True True eliminatorTy + let elimSig = "-- eliminator signature: " ++ showTmImpls eliminatorTy eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs) let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses - elimLog $ "-- eliminator definition: " ++ showDeclImp True eliminatorDef - Control.Monad.State.lift $ idrisCatch (elabDecl EAll info eliminatorTyDecl) (\err -> return ()) + elimLog $ "-- eliminator definition: " ++ (show . showDeclImp True) eliminatorDef + State.lift $ idrisCatch (elabDecl EAll info eliminatorTyDecl) (\err -> return ()) -- Do not elaborate clauses if there aren't any case eliminatorClauses of [] -> return () - _ -> Control.Monad.State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ()) + _ -> State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ()) where elimLog :: String -> EliminatorState () - elimLog s = Control.Monad.State.lift (logLvl 2 s) + elimLog s = State.lift (logLvl 2 s) elimFC :: FC elimFC = fileFC "(eliminator)" @@ -309,7 +347,7 @@ applyNS :: Name -> [String] -> Name applyNS n [] = n - applyNS n ns = NS n ns + applyNS n ns = sNS n ns splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm) splitPi = splitPi' [] @@ -348,29 +386,29 @@ simpleName :: Name -> String simpleName (NS n _) = simpleName n - simpleName (MN i n) = n ++ show i + simpleName (MN i n) = str n ++ show i simpleName n = show n nameSpaces :: Name -> [String] - nameSpaces (NS _ ns) = ns + nameSpaces (NS _ ns) = map str ns nameSpaces _ = [] freshName :: String -> EliminatorState Name freshName key = do nameMap <- get let i = fromMaybe 0 (Map.lookup key nameMap) - let name = key ++ show i ++ "__" + let name = key ++ show i put $ Map.insert key (i+1) nameMap - return (MN i name) + return (sUN name) scrutineeName :: Name - scrutineeName = MN 0 "scrutinee" + scrutineeName = sUN "scrutinee" scrutineeArgName :: Name - scrutineeArgName = MN 0 "scrutineeArg" + scrutineeArgName = sUN "scrutineeArg" motiveName :: Name - motiveName = MN 0 "prop" + motiveName = sUN "prop" mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm mkMotive n paramPos params indicies = @@ -434,9 +472,9 @@ splitArgPms _ = ([],[]) - implicitIndexes :: (String, Name, PTerm, FC) -> EliminatorState [(Name, Plicity, PTerm)] - implicitIndexes (cns@(doc, cnm, ty, fc)) = do - i <- Control.Monad.State.lift getIState + implicitIndexes :: (String, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)] + implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do + i <- State.lift getIState implargs' <- case lookupCtxt cnm (idris_implicits i) of [] -> do fail $ "Error while showing implicits for " ++ show cnm [args] -> do return args @@ -449,18 +487,18 @@ in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs _ -> return implargs - extractConsTerm :: (String, Name, PTerm, FC) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm - extractConsTerm (doc, cnm, ty, fc) generalParameters = do + extractConsTerm :: (String, Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm + extractConsTerm (doc, cnm, ty, fc, fs) generalParameters = do let cons' = replaceParams paramPos generalParameters ty let (args, resTy) = splitPi cons' - implidxs <- implicitIndexes (doc, cnm, ty, fc) + implidxs <- implicitIndexes (doc, cnm, ty, fc, fs) consArgs <- namePis True args let recArgs = findRecArgs consArgs let recMotives = map applyRecMotive recArgs let (_, consIdxs) = splitArgPms resTy return $ piConstr (implidxs ++ consArgs ++ recMotives) (applyMotive consIdxs (applyCons cnm consArgs)) where applyRecMotive :: (Name, Plicity, PTerm) -> (Name, Plicity, PTerm) - applyRecMotive (n,_,ty) = (MN 0 $ "ih" ++ simpleName n, expl, applyMotive idxs (PRef elimFC n)) + applyRecMotive (n,_,ty) = (sUN $ "ih" ++ simpleName n, expl, applyMotive idxs (PRef elimFC n)) where (_, idxs) = splitArgPms ty findRecArgs :: [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] @@ -485,12 +523,12 @@ convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t) convertImplPi _ = Nothing - generateEliminatorClauses :: (String, Name, PTerm, FC) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause - generateEliminatorClauses (doc, cnm, ty, fc) cnsElim generalArgs generalParameters = do + generateEliminatorClauses :: (String, Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause + generateEliminatorClauses (doc, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do let cons' = replaceParams paramPos generalParameters ty let (args, resTy) = splitPi cons' - i <- Control.Monad.State.lift getIState - implidxs <- implicitIndexes (doc, cnm, ty, fc) + i <- State.lift getIState + implidxs <- implicitIndexes (doc, cnm, ty, fc, fs) let (_, generalIdxs') = splitArgPms resTy let generalIdxs = map pexp generalIdxs' consArgs <- namePis True args @@ -511,6 +549,7 @@ (zip [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts] [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl])) + addNameHint eqTy (sUN "prf") elabDecl EAll toplevel elimDecl mapM_ elabPrim primitives -- Special case prim__believe_me because it doesn't work on just constants @@ -533,11 +572,11 @@ p_believeMe [_,_,x] = Just x p_believeMe _ = Nothing - believeTy = Bind (UN "a") (Pi (TType (UVar (-2)))) - (Bind (UN "b") (Pi (TType (UVar (-2)))) - (Bind (UN "x") (Pi (V 1)) (V 1))) + believeTy = Bind (sUN "a") (Pi (TType (UVar (-2)))) + (Bind (sUN "b") (Pi (TType (UVar (-2)))) + (Bind (sUN "x") (Pi (V 1)) (V 1))) elabBelieveMe - = do let prim__believe_me = (UN "prim__believe_me") + = do let prim__believe_me = sUN "prim__believe_me" updateContext (addOperator prim__believe_me believeTy 3 p_believeMe) setTotality prim__believe_me (Partial NotCovering) i <- getIState @@ -551,19 +590,19 @@ | otherwise = Just (VApp vnNothing VErased) p_synEq args = Nothing - nMaybe = P (TCon 0 2) (NS (UN "Maybe") ["Maybe", "Prelude"]) Erased - vnJust = VP (DCon 1 2) (NS (UN "Just") ["Maybe", "Prelude"]) VErased - vnNothing = VP (DCon 0 1) (NS (UN "Nothing") ["Maybe", "Prelude"]) VErased + nMaybe = P (TCon 0 2) (sNS (sUN "Maybe") ["Maybe", "Prelude"]) Erased + vnJust = VP (DCon 1 2) (sNS (sUN "Just") ["Maybe", "Prelude"]) VErased + vnNothing = VP (DCon 0 1) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased vnRefl = VP (DCon 0 2) eqCon VErased - synEqTy = Bind (UN "a") (Pi (TType (UVar (-3)))) - (Bind (UN "b") (Pi (TType (UVar (-3)))) - (Bind (UN "x") (Pi (V 1)) - (Bind (UN "y") (Pi (V 1)) + synEqTy = Bind (sUN "a") (Pi (TType (UVar (-3)))) + (Bind (sUN "b") (Pi (TType (UVar (-3)))) + (Bind (sUN "x") (Pi (V 1)) + (Bind (sUN "y") (Pi (V 1)) (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased) [V 3, V 2, V 1, V 0]])))) elabSynEq - = do let synEq = UN "prim__syntactic_eq" + = do let synEq = sUN "prim__syntactic_eq" updateContext (addOperator synEq synEqTy 4 p_synEq) setTotality synEq (Total []) @@ -601,13 +640,13 @@ -- Execute the type provider and normalise the result -- use 'run__provider' to convert to a primitive IO action - rhs <- execute (mkApp (P Ref (UN "run__provider") Erased) + rhs <- execute (mkApp (P Ref (sUN "run__provider") Erased) [Erased, 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' + tm <- getProvided fc rhs' -- Finally add a top-level definition of the provided term elabClauses info fc [] n [PClause fc n (PRef fc n) [] (delab i tm) []] @@ -619,9 +658,10 @@ 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 + | (P _ (UN io) _, [prov']) <- unApply prov + , (P _ (NS (UN prov) [provs]) _, [tp']) <- unApply prov' + , tp == tp', io == txt "IO" + , prov == txt "Provider" && provs == txt "Providers" = True isProviderOf _ _ = False -- | Elaborate a type provider @@ -631,8 +671,8 @@ i <- getIState let lhs = addImplPat i lhs_in ((lhs', dlhs, []), _) <- - tclift $ elaborate ctxt (MN 0 "transLHS") infP [] - (erun fc (buildTC i info True False (UN "transform") + tclift $ elaborate ctxt (sMN 0 "transLHS") infP [] + (erun fc (buildTC i info True [] (sUN "transform") (infTerm lhs))) let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs' @@ -642,13 +682,13 @@ logLvl 3 ("Transform LHS " ++ show clhs_tm) let rhs = addImplBound i (map fst newargs) rhs_in ((rhs', defer), _) <- - tclift $ elaborate ctxt (MN 0 "transRHS") clhs_ty [] + tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty [] (do pbinds lhs_tm - erun fc (build i info False (UN "transform") rhs) + setNextName + erun fc (build i info False [] (sUN "transform") rhs) erun fc $ psolve lhs_tm tt <- get_term - let (tm, ds) = runState (collectDeferred Nothing tt) [] - return (tm, ds)) + return (runState (collectDeferred Nothing tt) [])) (crhs_tm, crhs_ty) <- recheckC fc [] rhs' logLvl 3 ("Transform RHS " ++ show crhs_tm) when safe $ case converts ctxt [] clhs_tm crhs_tm of @@ -661,7 +701,7 @@ 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 [] (PDatadecl tyn ty [(cdoc, cn, cty, fc)]) + = do elabData info syn doc fc [] (PDatadecl tyn ty [(cdoc, cn, cty, fc, [])]) cty' <- implicit syn cn cty i <- getIState cty <- case lookupTy cn (tt_ctxt i) of @@ -715,18 +755,18 @@ getRecTy (PPi _ n ty s) = getRecTy s getRecTy t = t - rec = MN 0 "rec" + rec = sMN 0 "rec" - mkp (UN n) = MN 0 ("p_" ++ n) - mkp (MN i n) = MN i ("p_" ++ n) + mkp (UN n) = sMN 0 ("p_" ++ str n) + mkp (MN i n) = sMN i ("p_" ++ str n) mkp (NS n s) = NS (mkp n) s - mkImp (UN n) = UN ("implicit_" ++ n) - mkImp (MN i n) = MN i ("implicit_" ++ n) + mkImp (UN n) = sUN ("implicit_" ++ str n) + mkImp (MN i n) = sMN i ("implicit_" ++ str n) mkImp (NS n s) = NS (mkImp n) s - mkType (UN n) = UN ("set_" ++ n) - mkType (MN i n) = MN i ("set_" ++ n) + mkType (UN n) = sUN ("set_" ++ str n) + mkType (MN i n) = sMN i ("set_" ++ str n) mkType (NS n s) = NS (mkType n) s mkProj recty substs cimp ((pn_in, pty), pos) @@ -749,11 +789,11 @@ mkUpdate recty k num ((pn, pty), pos) = do let setname = expandNS syn $ mkType pn - let valname = MN 0 "updateval" + let valname = sMN 0 "updateval" let pt = k (PPi expl pn pty (PPi expl rec recty recty)) let pfnTy = PTy "" defaultSyntax fc [] setname pt - let pls = map (\x -> PRef fc (MN x "field")) [0..num-1] + let pls = map (\x -> PRef fc (sMN x "field")) [0..num-1] let lhsArgs = pls let rhsArgs = take pos pls ++ (PRef fc valname) : drop (pos + 1) pls @@ -768,17 +808,17 @@ return (pn, pfnTy, PClauses fc [] setname [pclause]) elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool -> - (String, Name, PTerm, FC) -> Idris (Name, Type) -elabCon info syn tn codata (doc, n, t_in, fc) + (String, Name, PTerm, FC, [Name]) -> Idris (Name, Type) +elabCon info syn tn codata (doc, n, t_in, fc, forcenames) = do checkUndefined fc n ctxt <- getContext i <- getIState t_in <- implicit syn n (if codata then mkLazy t_in else t_in) let t = addImpl i t_in - logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ showImp Nothing True False t + logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] - (errAt "constructor " n (erun fc (build i info False n t))) + (errAt "constructor " n (erun fc (build i info False [] n t))) logLvl 2 $ "Rechecking " ++ show t' def' <- checkDef fc defer let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def' @@ -792,7 +832,10 @@ addIBC (IBCDef n) addDocStr n doc addIBC (IBCDoc n) - forceArgs n cty' + let fs = map (getNamePos 0 t) forcenames + -- FIXME: 'forcenames' is an almighty hack! Need a better way of + -- erasing non-forceable things + forceArgs tn n (mapMaybe (getNamePos 0 t) forcenames) cty' return (n, cty') where tyIs (Bind n b sc) = tyIs sc @@ -801,9 +844,15 @@ else return () tyIs t = tclift $ tfail (At fc (Msg (show t ++ " is not " ++ show tn))) - mkLazy (PPi pl n ty sc) = PPi (pl { plazy = True }) n ty (mkLazy sc) + mkLazy (PPi pl n ty sc) + = PPi (pl { pargopts = nub (Lazy : pargopts pl) }) n ty (mkLazy sc) mkLazy t = t + getNamePos :: Int -> PTerm -> Name -> Maybe Int + getNamePos i (PPi _ n _ sc) x | n == x = Just i + | otherwise = getNamePos (i + 1) sc x + getNamePos _ _ _ = Nothing + -- | Elaborate a collection of left-hand and right-hand pairs - that is, a -- top-level definition. elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris () @@ -819,6 +868,7 @@ -- question: CAFs in where blocks? tclift $ tfail $ At fc (NoTypeDecl n) [ty] -> return ty + let atys = map snd (getArgTys fty) pats_in <- mapM (elabClause info opts) (zip [0..] cs) logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in @@ -901,7 +951,7 @@ let optpdef = map debind optpats -- \$ map (simple_lhs (tt_ctxt ist)) optpats tree@(CaseDef scargs sc _) <- tclift $ - simpleCase tcase False reflect CompileTime fc pdef + simpleCase tcase False reflect CompileTime fc atys pdef cov <- coverage pmissing <- if cov @@ -910,9 +960,9 @@ missing' <- filterM (checkPossible info fc True n) missing let clhs = map getLHS pdef logLvl 2 $ "Must be unreachable:\n" ++ - showSep "\n" (map (showImp Nothing True False) missing') ++ + showSep "\n" (map showTmImpls missing') ++ "\nAgainst: " ++ - showSep "\n" (map (\t -> showImp Nothing True False (delab ist t)) (map getLHS pdef)) + showSep "\n" (map (\t -> showTmImpls (delab ist t)) (map getLHS pdef)) -- filter out anything in missing' which is -- matched by any of clhs. This might happen since -- unification may force a variable to take a @@ -949,7 +999,7 @@ let knowncovering = (pcover && cov) || AssertTotal `elem` opts tree' <- tclift $ simpleCase tcase knowncovering reflect - RunTime fc pdef' + RunTime fc atys pdef' logLvl 3 (show tree) logLvl 3 $ "Optimised: " ++ show tree' ctxt <- getContext @@ -962,6 +1012,7 @@ tcase knowncovering reflect (AssertTotal `elem` opts) + atys pats pdef pdef pdef_inl pdef' ty) addIBC (IBCDef n) @@ -971,7 +1022,7 @@ when (tot /= Unchecked) $ addIBC (IBCTotal n tot) i <- getIState case lookupDef n (tt_ctxt i) of - (CaseOp _ _ _ _ cd : _) -> + (CaseOp _ _ _ _ _ cd : _) -> let (scargs, sc) = cases_compiletime cd (scargs', sc') = cases_runtime cd in do let calls = findCalls sc' scargs' @@ -1058,7 +1109,7 @@ mkSpecialised ist specapp_in = do let (specTy, specapp) = getSpecTy ist specapp_in - let (n, newnm, [(lhs, rhs)]) = getSpecClause ist specapp + let (n, newnm, pats) = getSpecClause ist specapp let undef = case lookupDef newnm (tt_ctxt ist) of [] -> True _ -> False @@ -1073,10 +1124,12 @@ iLOG $ "PE definition type : " ++ (show specTy) ++ "\n" ++ show opts logLvl 2 $ "PE definition " ++ show newnm ++ ":\n" ++ - (showImp Nothing True False lhs ++ " = " ++ - showImp Nothing True False rhs) + showSep "\n" + (map (\ (lhs, rhs) -> + (showTmImpls lhs ++ " = " ++ + showTmImpls rhs)) pats) elabType info defaultSyntax "" fc opts newnm specTy - let def = [PClause fc newnm lhs [] rhs []] + let def = map (\ (lhs, rhs) -> PClause fc newnm lhs [] rhs []) pats elabClauses info fc opts newnm def logLvl 1 $ "Specialised " ++ show newnm) -- if it doesn't work, just don't specialise. Could happen for lots @@ -1112,7 +1165,7 @@ _ -> error "Can't happen (getSpecTy)" getSpecClause ist (n, args) - = let newnm = UN ("__"++show (nsroot n) ++ "_" ++ + = let newnm = sUN ("__"++show (nsroot n) ++ "_" ++ showSep "_" (map showArg args)) in -- UN (show n ++ show (map snd args)) in (n, newnm, mkPE_TermDecl ist newnm n args) @@ -1128,7 +1181,7 @@ = do ctxt <- getContext i <- getIState let tm = addImpl i tm_in - logLvl 10 (showImp Nothing True False tm) + logLvl 10 (showTmImpls tm) -- try: -- * ordinary elaboration -- * elaboration as a Type @@ -1137,8 +1190,8 @@ ((tm', defer, is), _) <- -- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) [] -- (build i info aspat (MN 0 "val") tm)) - tclift (elaborate ctxt (MN 0 "val") infP [] - (build i info aspat (MN 0 "val") (infTerm tm))) + tclift (elaborate ctxt (sMN 0 "val") infP [] + (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm))) let vtm = orderPats (getInferTerm tm') def' <- checkDef (fileFC "(input)") defer @@ -1168,8 +1221,8 @@ i <- getIState let lhs = addImpl i lhs_in -- if the LHS type checks, it is possible - case elaborate ctxt (MN 0 "patLHS") infP [] - (erun fc (buildTC i info True tcgen fname (infTerm lhs))) of + case elaborate ctxt (sMN 0 "patLHS") infP [] + (erun fc (buildTC i info True [] fname (infTerm lhs))) of OK ((lhs', _, _), _) -> do let lhs_tm = orderPats (getInferTerm lhs') case recheck ctxt [] (forget lhs_tm) lhs_tm of @@ -1219,13 +1272,13 @@ let params = getParamsInType i [] fn_is fn_ty let lhs = stripUnmatchable i $ addImplPat i (propagateParams params (stripLinear i lhs_in)) - logLvl 5 ("LHS: " ++ show fc ++ " " ++ showImp Nothing True False lhs) + logLvl 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs) logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is)) ((lhs', dlhs, []), _) <- - tclift $ elaborate ctxt (MN 0 "patLHS") infP [] + tclift $ elaborate ctxt (sMN 0 "patLHS") infP [] (errAt "left hand side of " fname - (erun fc (buildTC i info True tcgen fname (infTerm lhs)))) + (erun fc (buildTC i info True opts fname (infTerm lhs)))) let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs' logLvl 3 ("Elaborated: " ++ show lhs_tm) @@ -1234,10 +1287,12 @@ (clhs_c, clhsty) <- recheckC fc [] lhs_tm let clhs = normalise ctxt [] clhs_c - logLvl 3 ("Normalised LHS: " ++ showImp Nothing True False (delabMV i clhs)) + logLvl 3 ("Normalised LHS: " ++ showTmImpls (delabMV i clhs)) - addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs) - addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs)) + rep <- useREPL + when rep $ do + addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs) + addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs)) logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty) -- Elaborate where block @@ -1258,25 +1313,29 @@ mapM_ (elabDecl' EAll info) wbefore -- Now build the RHS, using the type of the LHS as the goal. i <- getIState -- new implicits from where block - logLvl 5 (showImp Nothing True False (expandParams decorate newargs defs (defs \\ decls) rhs_in)) + logLvl 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in)) let rhs = addImplBoundInf i (map fst newargs) (defs \\ decls) (expandParams decorate newargs defs (defs \\ decls) rhs_in) - logLvl 2 $ "RHS: " ++ showImp Nothing True False rhs + logLvl 2 $ "RHS: " ++ showTmImpls rhs ctxt <- getContext -- new context with where block added logLvl 5 "STARTING CHECK" ((rhs', defer, is), _) <- - tclift $ elaborate ctxt (MN 0 "patRHS") clhsty [] + tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty [] (do pbinds lhs_tm + setNextName (_, _, is) <- errAt "right hand side of " fname - (erun fc (build i info False fname rhs)) + (erun fc (build i info False opts fname rhs)) errAt "right hand side of " fname (erun fc $ psolve lhs_tm) + hs <- get_holes + aux <- getAux + mapM_ (elabCaseHole aux) hs tt <- get_term let (tm, ds) = runState (collectDeferred (Just fname) tt) [] return (tm, ds, is)) logLvl 5 "DONE CHECK" logLvl 2 $ "---> " ++ show rhs' - when (not (null defer)) $ iLOG $ "DEFERRED " ++ show defer + when (not (null defer)) $ iLOG $ "DEFERRED " ++ show (map fst defer) def' <- checkDef fc defer let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def' addDeferred def'' @@ -1292,6 +1351,7 @@ ctxt <- getContext logLvl 5 $ "Rechecking" + logLvl 6 $ " ==> " ++ show (forget rhs') (crhs, crhsty) <- recheckC fc [] rhs' logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty case converts ctxt [] clhsty crhsty of @@ -1299,6 +1359,20 @@ Error e -> ierror (At fc (CantUnify False clhsty crhsty e [] 0)) i <- getIState checkInferred fc (delab' i crhs True True) rhs + -- if the function is declared '%error_reverse', or its type, + -- then we'll try running it in reverse to improve error messages + let (ret_fam, _) = unApply (getRetTy crhsty) + rev <- case ret_fam of + P _ rfamn _ -> + case lookupCtxt rfamn (idris_datatypes i) of + [TI _ _ dopts _] -> + return (DataErrRev `elem` dopts) + _ -> return False + _ -> return False + + when (rev || ErrorReverse `elem` opts) $ do + addIBC (IBCErrRev (crhs, clhs)) + addErrRev (crhs, clhs) return $ Right (clhs, crhs) where decorate (NS x ns) @@ -1368,18 +1442,38 @@ = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps) propagateParams ps x = x + -- if a hole is just an argument/result of a case block, treat it as + -- the unit type. Hack to help elaborate case in do blocks. + elabCaseHole aux h = do + focus h + g <- goal + case g of + TType _ -> when (any (isArg h) aux) $ do apply (Var unitTy) []; solve + _ -> return () + + -- Is the name a pattern argument in the declaration + isArg :: Name -> PDecl -> Bool + isArg n (PClauses _ _ _ cs) = any isArg' cs + where + isArg' (PClause _ _ (PApp _ _ args) _ _ _) + = any (\x -> case x of + PRef _ n' -> n == n' + _ -> False) (map getTm args) + isArg' _ = False + isArg _ _ = False + elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock) = do let tcgen = Dictionary `elem` opts ctxt <- getContext -- Build the LHS as an "Infer", and pull out its type and -- pattern bindings i <- getIState - let lhs = addImplPat i lhs_in - logLvl 5 ("LHS: " ++ showImp Nothing True False lhs) + let lhs = addImplPat i (stripLinear i lhs_in) + logLvl 5 ("LHS: " ++ showTmImpls lhs) ((lhs', dlhs, []), _) <- - tclift $ elaborate ctxt (MN 0 "patLHS") infP [] + tclift $ elaborate ctxt (sMN 0 "patLHS") infP [] (errAt "left hand side of with in " fname - (erun fc (buildTC i info True tcgen fname (infTerm lhs))) ) + (erun fc (buildTC i info True opts fname (infTerm lhs))) ) let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs' let ret_ty = getRetTy lhs_ty @@ -1388,15 +1482,16 @@ logLvl 5 ("Checked " ++ show clhs) let bargs = getPBtys lhs_tm let wval = addImplBound i (map fst bargs) wval_in - logLvl 5 ("Checking " ++ showImp Nothing True False wval) + logLvl 5 ("Checking " ++ showTmImpls wval) -- Elaborate wval in this context ((wval', defer, is), _) <- - tclift $ elaborate ctxt (MN 0 "withRHS") + tclift $ elaborate ctxt (sMN 0 "withRHS") (bindTyArgs PVTy bargs infP) [] (do pbinds lhs_tm + setNextName -- TODO: may want where here - see winfo abpve (_', d, is) <- errAt "with value in " fname - (erun fc (build i info False fname (infTerm wval))) + (erun fc (build i info False opts fname (infTerm wval))) erun fc $ psolve lhs_tm tt <- get_term return (tt, d, is)) @@ -1423,11 +1518,11 @@ let wargtype = getRetTy cwvaltyN logLvl 5 ("Abstract over " ++ show wargval) let wtype = bindTyArgs Pi (bargs_pre ++ - (MN 0 "warg", wargtype) : - map (abstract (MN 0 "warg") wargval wargtype) bargs_post) - (substTerm wargval (P Bound (MN 0 "warg") wargtype) ret_ty) + (sMN 0 "warg", wargtype) : + map (abstract (sMN 0 "warg") wargval wargtype) bargs_post) + (substTerm wargval (P Bound (sMN 0 "warg") wargtype) ret_ty) logLvl 3 ("New function type " ++ show wtype) - let wname = MN windex (show fname) + let wname = sMN windex (show fname) let imps = getImps wtype -- add to implicits context putIState (i { idris_implicits = addDef wname imps (idris_implicits i) }) @@ -1451,13 +1546,14 @@ (map (pexp . (PRef fc) . fst) bargs_pre ++ pexp wval : (map (pexp . (PRef fc) . fst) bargs_post)) - logLvl 5 ("New RHS " ++ showImp Nothing True False rhs) + logLvl 5 ("New RHS " ++ showTmImpls rhs) ctxt <- getContext -- New context with block added i <- getIState ((rhs', defer, is), _) <- - tclift $ elaborate ctxt (MN 0 "wpatRHS") clhsty [] + tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty [] (do pbinds lhs_tm - (_, d, is) <- erun fc (build i info False fname rhs) + setNextName + (_, d, is) <- erun fc (build i info False opts fname rhs) psolve lhs_tm tt <- get_term return (tt, d, is)) @@ -1481,8 +1577,8 @@ mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres) = do i <- getIState let tm = addImplPat i tm_in - logLvl 2 ("Matching " ++ showImp Nothing True False tm ++ " against " ++ - showImp Nothing True False toplhs) + logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " ++ + showTmImpls toplhs) case matchClause i toplhs tm of Left (a,b) -> trace ("matchClause: " ++ show a ++ " =/= " ++ show b) (ifail $ show fc ++ ":with clause does not match top level") Right mvars -> @@ -1492,8 +1588,8 @@ mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs) = do i <- getIState let tm = addImplPat i tm_in - logLvl 2 ("Matching " ++ showImp Nothing True False tm ++ " against " ++ - showImp Nothing True False toplhs) + logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " ++ + showTmImpls toplhs) withs' <- mapM (mkAuxC wname toplhs ns ns') withs case matchClause i toplhs tm of Left (a,b) -> trace ("matchClause: " ++ show a ++ " =/= " ++ show b) (ifail $ show fc ++ "with clause does not match top level") @@ -1535,12 +1631,14 @@ FC -> [PTerm] -> Name -> [(Name, PTerm)] -> [PDecl] -> Idris () elabClass info syn doc fc constraints tn ps ds - = do let cn = UN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn) + = do let cn = sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn) let tty = pibind ps PType let constraint = PApp fc (PRef fc tn) (map (pexp . PRef fc) (map fst ps)) -- build data declaration let mdecls = filter tydecl ds -- method declarations + let idecls = filter instdecl ds -- default superclass instance declarations + mapM_ checkDefaultSuperclassInstance idecls let mnames = map getMName mdecls logLvl 2 $ "Building methods " ++ show mnames ims <- mapM (tdecl mnames) mdecls @@ -1549,16 +1647,16 @@ let (methods, imethods) = unzip (map (\ ( x,y,z) -> (x, y)) ims) let defaults = map (\ (x, (y, z)) -> (x,y)) defs - addClass tn (CI cn (map nodoc imethods) defaults (map fst ps) []) + addClass tn (CI cn (map nodoc imethods) defaults idecls (map fst ps) []) -- build instance constructor type -- decorate names of functions to ensure they can't be referred -- to elsewhere in the class declaration let cty = impbind ps $ conbind constraints $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods) constraint - let cons = [("", cn, cty, fc)] + let cons = [("", cn, cty, fc, [])] let ddecl = PDatadecl tn tty cons - logLvl 5 $ "Class data " ++ showDImp True ddecl + logLvl 5 $ "Class data " ++ show (showDImp True ddecl) elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc [] ddecl -- for each constraint, build a top level function to chase it logLvl 5 $ "Building functions" @@ -1571,7 +1669,6 @@ mapM_ (elabDecl EAll info) (concat fns) -- add the default definitions mapM_ (elabDecl EAll info) (concat (map (snd.snd) defs)) - i <- getIState addIBC (IBCClass tn) where nodoc (n, (_, o, t)) = (n, (o, t)) @@ -1582,15 +1679,26 @@ mdec (NS x n) = NS (mdec x) n mdec x = x + -- TODO: probably should normalise + checkDefaultSuperclassInstance (PInstance _ fc cs n ps _ _ _) + = do when (not $ null cs) . tclift + $ tfail (At fc (Msg $ "Default superclass instances can't have constraints.")) + i <- getIState + let t = PApp fc (PRef fc n) (map pexp ps) + let isConstrained = any (== t) constraints + when (not isConstrained) . tclift + $ tfail (At fc (Msg $ "Default instances must be for a superclass constraint on the containing class.")) + return () + impbind [] x = x impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x) - conbind (ty : ns) x = PPi constraint (MN 0 "class") ty (conbind ns x) + conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x) conbind [] x = x getMName (PTy _ _ _ _ n _) = nsroot n tdecl allmeths (PTy doc syn _ o n t) = do t' <- implicit' syn allmeths n t - logLvl 5 $ "Method " ++ show n ++ " : " ++ showImp Nothing True False t' + logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t' return ( (n, (toExp (map fst ps) Exp t')), (n, (doc, o, (toExp (map fst ps) Imp t'))), (n, (syn, o, t) ) ) @@ -1608,25 +1716,27 @@ _ -> ifail $ show n ++ " is not a method" defdecl _ _ _ = ifail "Can't happen (defdecl)" - defaultdec (UN n) = UN ("default#" ++ n) + defaultdec (UN n) = sUN ("default#" ++ str n) defaultdec (NS n ns) = NS (defaultdec n) ns tydecl (PTy _ _ _ _ _ _) = True tydecl _ = False + instdecl (PInstance _ _ _ _ _ _ _ _) = True + instdecl _ = False clause (PClauses _ _ _ _) = True clause _ = False -- Generate a function for chasing a dictionary constraint cfun cn c syn all con - = do let cfn = UN ('@':'@':show cn ++ "#" ++ show con) + = do let cfn = sUN ('@':'@':show cn ++ "#" ++ show con) -- SN (ParentN cn (show con)) - let mnames = take (length all) $ map (\x -> MN x "meth") [0..] + let mnames = take (length all) $ map (\x -> sMN x "meth") [0..] let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames) let lhs = PApp fc (PRef fc cfn) [pconst capp] let rhs = PResolveTC (fileFC "HACK") - let ty = PPi constraint (MN 0 "pc") c con - iLOG (showImp Nothing True False ty) - iLOG (showImp Nothing True False lhs ++ " = " ++ showImp Nothing True False rhs) + let ty = PPi constraint (sMN 0 "pc") c con + iLOG (showTmImpls ty) + iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs) i <- getIState let conn = case con of PRef _ n -> n @@ -1644,15 +1754,15 @@ -- dictionary (this is inlinable, always) tfun cn c syn all (m, (doc, o, ty)) = do let ty' = insertConstraint c ty - let mnames = take (length all) $ map (\x -> MN x "meth") [0..] + let mnames = take (length all) $ map (\x -> sMN x "meth") [0..] let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames) let margs = getMArgs ty - let anames = map (\x -> MN x "arg") [0..] + let anames = map (\x -> sMN x "arg") [0..] let lhs = PApp fc (PRef fc m) (pconst capp : lhsArgs margs anames) let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames) - iLOG (showImp Nothing True False ty) + iLOG (showTmImpls ty) iLOG (show (m, ty', capp, margs)) - iLOG (showImp Nothing True False lhs ++ " = " ++ showImp Nothing True False rhs) + iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs) return [PTy doc syn fc o m ty', PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]] @@ -1676,7 +1786,7 @@ insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc) = PPi p n ty (insertConstraint c sc) - insertConstraint c sc = PPi constraint (MN 0 "class") c sc + insertConstraint c sc = PPi constraint (sMN 0 "class") c sc -- make arguments explicit and don't bind class parameters toExp ns e (PPi (Imp l s _ p) n ty sc) @@ -1686,30 +1796,30 @@ toExp ns e sc = sc elabInstance :: ElabInfo -> SyntaxInfo -> + ElabWhat -> -- phase FC -> [PTerm] -> -- constraints Name -> -- the class [PTerm] -> -- class parameters (i.e. instance) PTerm -> -- full instance type Maybe Name -> -- explicit name [PDecl] -> Idris () -elabInstance info syn fc cs n ps t expn ds - = do i <- getIState - (n, ci) <- case lookupCtxtName n (idris_classes i) of - [c] -> return c - _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class" - let constraint = PApp fc (PRef fc n) (map pexp ps) - let iname = case expn of - Nothing -> SN (InstanceN n (map show ps)) - -- UN ('@':show n ++ "$" ++ show ps) - Just nm -> nm +elabInstance info syn what fc cs n ps t expn ds = do + i <- getIState + (n, ci) <- case lookupCtxtName n (idris_classes i) of + [c] -> return c + _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class" + let constraint = PApp fc (PRef fc n) (map pexp ps) + let iname = mkiname n ps expn + when (what /= EDefns) $ do nty <- elabType' True info syn "" fc [] iname t -- if the instance type matches any of the instances we have already, -- and it's not a named instance, then it's overlapping, so report an error case expn of - Nothing -> do mapM_ (checkNotOverlapping i (delab i nty)) + Nothing -> do mapM_ (maybe (return ()) overlapping . findOverlapping i (delab i nty)) (class_instances ci) addInstance intInst n iname Just _ -> addInstance intInst n iname + when (what /= ETypes) $ do let ips = zip (class_params ci) ps let ns = case n of NS n ns' -> ns' @@ -1720,6 +1830,9 @@ PApp _ _ args -> getWParams args _ -> return []) ps let pnames = map pname (concat (nub wparams)) + let superclassInstances = map (substInstance ips pnames) (class_default_superclasses ci) + undefinedSuperclassInstances <- filterM (fmap not . isOverlapping i) superclassInstances + mapM_ (elabDecl EAll info) undefinedSuperclassInstances let all_meths = map (nsroot . fst) (class_methods ci) let mtys = map (\ (n, (op, t)) -> let t_in = substMatchesShadow ips pnames t @@ -1737,7 +1850,7 @@ let wbTys = map mkTyDecl mtys let wbVals = map (decorateid (decorate ns iname)) ds' let wb = wbTys ++ wbVals - logLvl 3 $ "Method types " ++ showSep "\n" (map (showDeclImp True . mkTyDecl) mtys) + logLvl 3 $ "Method types " ++ showSep "\n" (map (show . showDeclImp True . mkTyDecl) mtys) logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++ show (concat (nub wparams)) let lhs = PRef fc iname @@ -1746,7 +1859,7 @@ let idecls = [PClauses fc [Dictionary] iname [PClause fc iname lhs [] rhs wb]] iLOG (show idecls) - mapM (elabDecl EAll info) idecls + mapM_ (elabDecl EAll info) idecls addIBC (IBCInstance intInst n iname) -- -- for each constraint, build a top level function to chase it -- logLvl 5 $ "Building functions" @@ -1757,36 +1870,66 @@ [PConstant (AType (ATInt ITNative))] -> True _ -> False - checkNotOverlapping i t n - | take 2 (show n) == "@@" = return () + mkiname n' ps' expn' = + case expn' of + Nothing -> SN (sInstanceN n' (map show ps')) + Just nm -> nm + + substInstance ips pnames (PInstance syn _ cs n ps t expn ds) + = PInstance syn fc cs n (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds + + isOverlapping i (PInstance syn _ _ n ps t expn _) + = case lookupCtxtName n (idris_classes i) of + [(n, ci)] -> let iname = (mkiname n ps expn) in + case lookupTy iname (tt_ctxt i) of + [] -> elabFindOverlapping i ci iname syn t + (_:_) -> return True + _ -> return False -- couldn't find class, just let elabInstance fail later + + -- TODO: largely based upon elabType' - should try to abstract + elabFindOverlapping i ci iname syn t + = do ty' <- addUsingConstraints syn fc t + ty' <- implicit syn iname ty' + let ty = addImpl i ty' + ctxt <- getContext + ((tyT, _, _), _) <- + tclift $ elaborate ctxt iname (TType (UVal 0)) [] + (errAt "type of " iname (erun fc (build i info False [] iname ty))) + ctxt <- getContext + (cty, _) <- recheckC fc [] tyT + let nty = normalise ctxt [] cty + return $ any (isJust . findOverlapping i (delab i nty)) (class_instances ci) + + findOverlapping i t n + | take 2 (show n) == "@@" = Nothing | otherwise = case lookupTy n (tt_ctxt i) of [t'] -> let tret = getRetType t tret' = getRetType (delab i t') in case matchClause i tret' tret of - Right ms -> overlapping tret tret' + Right ms -> Just tret' Left _ -> case matchClause i tret tret' of - Right ms -> overlapping tret tret' - Left _ -> return () - _ -> return () - overlapping t t' = tclift $ tfail (At fc (Msg $ - "Overlapping instance: " ++ show t' ++ " already defined")) + Right ms -> Just tret' + Left _ -> Nothing + _ -> Nothing + overlapping t' = tclift $ tfail (At fc (Msg $ + "Overlapping instance: " ++ show t' ++ " already defined")) getRetType (PPi _ _ _ sc) = getRetType sc getRetType t = t mkMethApp (n, _, _, ty) = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty)) lamBind i (PPi (Constraint _ _ _) _ _ sc) sc' - = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc') + = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc') lamBind i (PPi _ n ty sc) sc' - = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc') + = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc') lamBind i _ sc = sc methArgs i (PPi (Imp _ _ _ _) n ty sc) - = PImp 0 True False n (PRef fc (MN i "meth")) "" : methArgs (i+1) sc + = PImp 0 True [] n (PRef fc (sMN i "meth")) "" : methArgs (i+1) sc methArgs i (PPi (Exp _ _ _ _) n ty sc) - = PExp 0 False (PRef fc (MN i "meth")) "" : methArgs (i+1) sc + = PExp 0 [] (PRef fc (sMN i "meth")) "" : methArgs (i+1) sc methArgs i (PPi (Constraint _ _ _) n ty sc) - = PConstraint 0 False (PResolveTC fc) "" : methArgs (i+1) sc + = PConstraint 0 [] (PResolveTC fc) "" : methArgs (i+1) sc methArgs i _ = [] papp fc f [] = f @@ -1807,14 +1950,14 @@ mkTyDecl (n, op, t, _) = PTy "" syn fc op n t - conbind (ty : ns) x = PPi constraint (MN 0 "class") ty (conbind ns x) + conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x) conbind [] x = x coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc) coninsert cs sc = conbind cs sc insertDefaults :: IState -> Name -> - [(Name, (Name, PDecl))] -> [String] -> + [(Name, (Name, PDecl))] -> [T.Text] -> [PDecl] -> [PDecl] insertDefaults i iname [] ns ds = ds insertDefaults i iname ((n,(dn, clauses)) : defs) ns ds @@ -1905,7 +2048,7 @@ elabDecl :: ElabWhat -> ElabInfo -> PDecl -> Idris () elabDecl what info d - = idrisCatch (elabDecl' what info d) (setAndReport) + = idrisCatch (withErrorReflection $ elabDecl' what info d) (setAndReport) elabDecl' _ info (PFix _ _ _) = return () -- nothing to elaborate @@ -1936,8 +2079,10 @@ [] -> [] elabClauses info f (o ++ o') n ps elabDecl' what info (PMutual f ps) - = do mapM_ (elabDecl ETypes info) ps - mapM_ (elabDecl EDefns info) ps + = do case ps of + [p] -> elabDecl what info p + _ -> do mapM_ (elabDecl ETypes info) ps + mapM_ (elabDecl EDefns info) ps -- Do totality checking after entire mutual block i <- get mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n @@ -1973,9 +2118,8 @@ = do iLOG $ "Elaborating class " ++ show n elabClass info (s { syn_params = [] }) doc f cs n ps ds elabDecl' what info (PInstance s f cs n ps t expn ds) - | what /= ETypes = do iLOG $ "Elaborating instance " ++ show n - elabInstance info s f cs n ps t expn ds + elabInstance info s what f cs n ps t expn ds elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty) | what /= ETypes = do iLOG $ "Elaborating record " ++ show tyn @@ -1999,8 +2143,11 @@ elabCaseBlock info opts d@(PClauses f o n ps) = do addIBC (IBCDef n) - logLvl 6 $ "CASE BLOCK: " ++ show (n, d) - elabDecl' EAll info (PClauses f (nub (o ++ opts)) n ps ) + logLvl 5 $ "CASE BLOCK: " ++ show (n, d) + let opts' = nub (o ++ opts) + -- propagate totality assertion to the new definitions + when (AssertTotal `elem` opts) $ setFlags n [AssertTotal] + elabDecl' EAll info (PClauses f opts' n ps ) -- elabDecl' info (PImport i) = loadModule i @@ -2010,8 +2157,8 @@ checkInferred :: FC -> PTerm -> PTerm -> Idris () checkInferred fc inf user = - do logLvl 6 $ "Checked to\n" ++ showImp Nothing True False inf ++ "\n\nFROM\n\n" ++ - showImp Nothing True False user + do logLvl 6 $ "Checked to\n" ++ showTmImpls inf ++ "\n\nFROM\n\n" ++ + showTmImpls user logLvl 10 $ "Checking match" i <- getIState tclift $ case matchClause' True i user inf of @@ -2028,8 +2175,8 @@ inferredDiff :: FC -> PTerm -> PTerm -> Idris Bool inferredDiff fc inf user = do i <- getIState - logLvl 6 $ "Checked to\n" ++ showImp Nothing True False inf ++ "\n" ++ - showImp Nothing True False user + logLvl 6 $ "Checked to\n" ++ showTmImpls inf ++ "\n" ++ + showTmImpls user tclift $ case matchClause' True i user inf of Right vs -> return False Left (x, y) -> return True diff --git a/src/Idris/ElabTerm.hs b/src/Idris/ElabTerm.hs --- a/src/Idris/ElabTerm.hs +++ b/src/Idris/ElabTerm.hs @@ -5,15 +5,22 @@ import Idris.AbsSyntax import Idris.DSL import Idris.Delaborate +import Idris.Error import Idris.ProofSearch -import Core.Elaborate hiding (Tactic(..)) -import Core.TT -import Core.Evaluate +import Idris.Core.Elaborate hiding (Tactic(..)) +import Idris.Core.TT +import Idris.Core.Evaluate +import Idris.Core.Typecheck (check) +import Control.Applicative ((<$>)) import Control.Monad -import Control.Monad.State +import Control.Monad.State.Strict import Data.List +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import qualified Data.Set as S +import qualified Data.Text as T import Debug.Trace @@ -35,10 +42,10 @@ -- Also find deferred names in the term and their types -build :: IState -> ElabInfo -> Bool -> Name -> PTerm -> +build :: IState -> ElabInfo -> Bool -> FnOpts -> Name -> PTerm -> ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl]) -build ist info pattern fn tm - = do elab ist info pattern False fn tm +build ist info pattern opts fn tm + = do elab ist info pattern opts fn tm ivs <- get_instances hs <- get_holes ptm <- get_term @@ -75,10 +82,13 @@ -- (Separate, so we don't go overboard resolving things that we don't -- know about yet on the LHS of a pattern def) -buildTC :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm -> +buildTC :: IState -> ElabInfo -> Bool -> FnOpts -> Name -> PTerm -> ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl]) -buildTC ist info pattern tcgen fn tm - = do elab ist info pattern tcgen fn tm +buildTC ist info pattern opts fn tm + = do -- set name supply to begin after highest index in tm + let ns = allNamesIn tm + initNextNameFrom ns + elab ist info pattern opts fn tm probs <- get_probs tm <- get_term case probs of @@ -94,19 +104,21 @@ -- Returns the set of declarations we need to add to complete the definition -- (most likely case blocks to elaborate) -elab :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm -> +elab :: IState -> ElabInfo -> Bool -> FnOpts -> Name -> PTerm -> ElabD () -elab ist info pattern tcgen fn tm +elab ist info pattern opts fn tm = do let loglvl = opt_logLevel (idris_options ist) when (loglvl > 5) $ unifyLog True compute -- expand type synonyms, etc - elabE (False, False) tm -- (in argument, guarded) + elabE (False, False, False) tm -- (in argument, guarded, in type) end_unify when pattern -- convert remaining holes to pattern vars (do update_term orderPats - tm <- get_term mkPat) where + tcgen = Dictionary `elem` opts + reflect = Reflection `elem` opts + isph arg = case getTm arg of Placeholder -> (True, priority arg) _ -> (False, priority arg) @@ -125,6 +137,7 @@ (h: hs) -> do patvar h; mkPat [] -> return () + elabE :: (Bool, Bool, Bool) -> PTerm -> ElabD () elabE ina t = {- do g <- goal tm <- get_term trace ("Elaborating " ++ show t ++ " : " ++ show g ++ "\n\tin " ++ show tm) @@ -139,43 +152,58 @@ -- ++ "\nholes " ++ show hs -- ++ "\nproblems " ++ show ps -- ++ "\n-----------\n") $ +-- trace ("ELAB " ++ show t') $ elab' ina t' local f = do e <- get_env return (f `elem` map fst e) + -- | Is a constant a type? + constType :: Const -> Bool + constType (AType _) = True + constType StrType = True + constType PtrType = True + constType VoidType = True + constType _ = False + + elab' :: (Bool, Bool, Bool) -- ^ (in an argument, guarded, in a type) + -> PTerm -- ^ The term to elaborate + -> ElabD () elab' ina (PNoImplicits t) = elab' ina t -- skip elabE step elab' ina PType = do apply RType []; solve +-- elab' (_,_,inty) (PConstant c) +-- | constType c && pattern && not reflect && not inty +-- = lift $ tfail (Msg "Typecase is not allowed") elab' ina (PConstant c) = do apply (RConstant c) []; solve elab' ina (PQuote r) = do fill r; solve - elab' ina (PTrue fc) = try (elab' ina (PRef fc unitCon)) - (elab' ina (PRef fc unitTy)) + elab' ina (PTrue fc _) = try (elab' ina (PRef fc unitCon)) + (elab' ina (PRef fc unitTy)) elab' ina (PFalse fc) = elab' ina (PRef fc falseTy) elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes = do g <- goal; resolveTC 5 g fn ist elab' ina (PResolveTC fc) - | True = do c <- unique_hole (MN 0 "class") + | True = do c <- getNameFrom (sMN 0 "class") instanceArg c | otherwise = do g <- goal try (resolveTC 2 g fn ist) - (do c <- unique_hole (MN 0 "class") + (do c <- getNameFrom (sMN 0 "class") instanceArg c) elab' ina (PRefl fc t) - = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder True, - pimp (MN 0 "x") t False]) + = elab' ina (PApp fc (PRef fc eqCon) [pimp (sMN 0 "A") Placeholder True, + pimp (sMN 0 "x") t False]) elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy) - [pimp (MN 0 "a") Placeholder True, - pimp (MN 0 "b") Placeholder False, + [pimp (sMN 0 "A") Placeholder True, + pimp (sMN 0 "B") Placeholder False, pexp l, pexp r]) - elab' ina@(_, a) (PPair fc l r) + elab' ina@(_, a, inty) (PPair fc _ l r) = do hnf_compute g <- goal case g of - TType _ -> elabE (True, a) (PApp fc (PRef fc pairTy) - [pexp l,pexp r]) - _ -> elabE (True, a) (PApp fc (PRef fc pairCon) - [pimp (MN 0 "A") Placeholder True, - pimp (MN 0 "B") Placeholder True, + TType _ -> elabE (True, a,inty) (PApp fc (PRef fc pairTy) + [pexp l,pexp r]) + _ -> elabE (True, a, inty) (PApp fc (PRef fc pairCon) + [pimp (sMN 0 "A") Placeholder True, + pimp (sMN 0 "B") Placeholder True, pexp l, pexp r]) elab' ina (PDPair fc l@(PRef _ n) t r) = case t of @@ -190,12 +218,12 @@ [pexp t, pexp (PLam n Placeholder r)]) asValue = elab' ina (PApp fc (PRef fc existsCon) - [pimp (MN 0 "a") t False, - pimp (MN 0 "P") Placeholder True, + [pimp (sMN 0 "a") t False, + pimp (sMN 0 "P") Placeholder True, pexp l, pexp r]) elab' ina (PDPair fc l t r) = elab' ina (PApp fc (PRef fc existsCon) - [pimp (MN 0 "a") t False, - pimp (MN 0 "P") Placeholder True, + [pimp (sMN 0 "a") t False, + pimp (sMN 0 "P") Placeholder True, pexp l, pexp r]) elab' ina (PAlternative True as) = do hnf_compute @@ -203,11 +231,10 @@ ctxt <- get_context let (tc, _) = unApply ty let as' = pruneByType tc ctxt as --- case as' of --- [a] -> elab' ina a --- as -> lift $ tfail $ CantResolveAlts (map showHd as) tryAll (zip (map (elab' ina) as') (map showHd as')) - where showHd (PApp _ h _) = show h + where showHd (PApp _ (PRef _ n) _) = show n + showHd (PRef _ n) = show n + showHd (PApp _ h _) = show h showHd x = show x elab' ina (PAlternative False as) = trySeq as @@ -218,7 +245,10 @@ trySeq' deferr (x : xs) = 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) +-- elab' (_, _, inty) (PRef fc f) +-- | isTConName f (tt_ctxt ist) && pattern && not reflect && not inty +-- = lift $ tfail (Msg "Typecase is not allowed") + elab' (ina, guarded, inty) (PRef fc n) | pattern && not (inparamBlock n) = do ctxt <- get_context let defined = case lookupTy n ctxt of [] -> False @@ -235,82 +265,80 @@ _ -> True elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f []) elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve - elab' ina@(_, a) (PLam n Placeholder sc) - = do -- n' <- unique_hole n - -- let sc' = mapPT (repN n n') sc - ptm <- get_term - g <- goal + elab' ina@(_, a, inty) (PLam n Placeholder sc) + = do -- if n is a type constructor name, this makes no sense... + ctxt <- get_context + when (isTConName n ctxt) $ + lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here") checkPiGoal n attack; intro (Just n); -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm) - elabE (True, a) sc; solve - where repN n n' (PRef fc x) | x == n' = PRef fc n' - repN _ _ t = t - elab' ina@(_, a) (PLam n ty sc) - = do hsin <- get_holes - ptmin <- get_term - tyn <- unique_hole (MN 0 "lamty") + elabE (True, a, inty) sc; solve + elab' ina@(_, a, inty) (PLam n ty sc) + = do tyn <- getNameFrom (sMN 0 "lamty") + -- if n is a type constructor name, this makes no sense... + ctxt <- get_context + when (isTConName n ctxt) $ + lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here") checkPiGoal n claim tyn RType + explicit tyn attack ptm <- get_term hs <- get_holes - -- trace ("BEFORE:\n" ++ show hsin ++ "\n" ++ show ptmin ++ - -- "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $ introTy (Var tyn) (Just n) - -- end_unify focus tyn - ptm <- get_term - hs <- get_holes - elabE (True, a) ty - elabE (True, a) sc + elabE (True, a, True) ty + elabE (True, a, inty) sc solve - elab' ina@(_,a) (PPi _ n Placeholder sc) - = do attack; arg n (MN 0 "ty"); elabE (True, a) sc; solve - elab' ina@(_,a) (PPi _ n ty sc) - = do attack; tyn <- unique_hole (MN 0 "ty") + elab' ina@(_, a, _) (PPi _ n Placeholder sc) + = do attack; arg n (sMN 0 "ty"); elabE (True, a, True) sc; solve + elab' ina@(_, a, _) (PPi _ n ty sc) + = do attack; tyn <- getNameFrom (sMN 0 "ty") claim tyn RType n' <- case n of MN _ _ -> unique_hole n _ -> return n forall n' (Var tyn) focus tyn - elabE (True, a) ty - elabE (True, a) sc + elabE (True, a, True) ty + elabE (True, a, True) sc solve - elab' ina@(_,a) (PLet n ty val sc) + elab' ina@(_, a, inty) (PLet n ty val sc) = do attack; - tyn <- unique_hole (MN 0 "letty") + tyn <- getNameFrom (sMN 0 "letty") claim tyn RType - valn <- unique_hole (MN 0 "letval") + valn <- getNameFrom (sMN 0 "letval") claim valn (Var tyn) + explicit valn letbind n (Var tyn) (Var valn) case ty of Placeholder -> return () _ -> do focus tyn - elabE (True, a) ty + explicit tyn + elabE (True, a, True) ty focus valn - elabE (True, a) val + elabE (True, a, True) val env <- get_env - elabE (True, a) sc + elabE (True, a, inty) sc -- HACK: If the name leaks into its type, it may leak out of -- scope outside, so substitute in the outer scope. expandLet n (case lookup n env of Just (Let t v) -> v) solve - elab' ina@(_,a) (PGoal fc r n sc) = do + elab' ina@(_, a, inty) (PGoal fc r n sc) = do rty <- goal attack - tyn <- unique_hole (MN 0 "letty") + tyn <- getNameFrom (sMN 0 "letty") claim tyn RType - valn <- unique_hole (MN 0 "letval") + valn <- getNameFrom (sMN 0 "letval") claim valn (Var tyn) letbind n (Var tyn) (Var valn) focus valn - elabE (True, a) (PApp fc r [pexp (delab ist rty)]) + elabE (True, a, True) (PApp fc r [pexp (delab ist rty)]) env <- get_env computeLet n - elabE (True, a) sc + elabE (True, a, inty) sc solve -- elab' ina (PLet n Placeholder -- (PApp fc r [pexp (delab ist rty)]) sc) @@ -322,7 +350,7 @@ -- new function name env <- get_env argTys <- claimArgTys env args - fn <- unique_hole (MN 0 "inf_fn") + fn <- getNameFrom (sMN 0 "inf_fn") let fty = fnTy argTys rty -- trace (show (ptm, map fst argTys)) $ focus fn -- build and defer the function application @@ -336,8 +364,8 @@ ans <- claimArgTys env xs return ((n, (False, forget nty)) : ans) claimArgTys env (_ : xs) - = do an <- unique_hole (MN 0 "inf_argTy") - aval <- unique_hole (MN 0 "inf_arg") + = do an <- getNameFrom (sMN 0 "inf_argTy") + aval <- getNameFrom (sMN 0 "inf_arg") claim an RType claim aval (Var an) ans <- claimArgTys env xs @@ -357,26 +385,25 @@ mkN n@(NS _ _) = n mkN n@(SN _) = n mkN n = case namespace info of - Just xs@(_:_) -> NS n xs + Just xs@(_:_) -> sNS n xs _ -> n - elab' (ina, g) (PMatchApp fc fn) + elab' ina (PMatchApp fc fn) = do (fn', imps) <- case lookupCtxtName fn (idris_implicits ist) of [(n, args)] -> return (n, map (const True) args) _ -> lift $ tfail (NoSuchVariable fn) ns <- match_apply (Var fn') (map (\x -> (x,0)) imps) solve + elab' (_, _, inty) (PApp fc (PRef _ f) args') + | isTConName f (tt_ctxt ist) && pattern && not reflect && not inty + = lift $ tfail (Msg "Typecase is not allowed") -- if f is local, just do a simple_app - 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' --- newtm <- mkSpecialised ist fc f (map getTm args') tm - env <- get_env - if (f `elem` map fst env && length args' == 1) + elab' (ina, g, inty) tm@(PApp fc (PRef _ f) args) + = do env <- get_env + if (f `elem` map fst env && length args == 1) then -- simple app, as below - do simple_app (elabE (ina, g) (PRef fc f)) - (elabE (True, g) (getTm (head args'))) + do simple_app (elabE (ina, g, inty) (PRef fc f)) + (elabE (True, g, inty) (getTm (head args))) (show tm) solve else @@ -389,26 +416,21 @@ -- we can unify with them case lookupCtxt f (idris_classes ist) of [] -> return () - _ -> mapM_ setInjective (map getTm args') + _ -> mapM_ setInjective (map getTm args) ctxt <- get_context let guarded = isConName f ctxt +-- trace ("args is " ++ show args) $ return () ns <- apply (Var f) (map isph args) - ptm <- get_term - g <- goal - -- Sort so that the implicit tactics go last +-- trace ("ns is " ++ show ns) $ return () + -- Sort so that the implicit tactics and alternatives go last let (ns', eargs) = unzip $ - sortBy (\(_,x) (_,y) -> - compare (priority x) (priority y)) - (zip ns args) - elabArgs (ina || not isinf, guarded) - [] fc False ns' (map (\x -> (lazyarg x, getTm x)) eargs) - mkSpecialised ist fc f (map getTm args') tm + sortBy cmpArg (zip ns args) + elabArgs ist (ina || not isinf, guarded, inty) + [] fc False f ns' (map (\x -> (lazyarg x, getTm x)) eargs) solve - ptm <- get_term ivs' <- get_instances - ps' <- get_probs - -- Attempt to resolve any type classes which have 'complete' types, - -- i.e. no holes in them + -- Attempt to resolve any type classes which have 'complete' types, + -- i.e. no holes in them when (not pattern || (ina && not tcgen && not guarded)) $ mapM_ (\n -> do focus n g <- goal @@ -422,6 +444,13 @@ (ivs' \\ ivs) where tcArg (n, PConstraint _ _ Placeholder _) = True tcArg _ = False + + -- normal < tactic < default tactic + cmpArg (_, x) (_, y) + = compare (priority x + alt x) (priority y + alt y) + where alt t = case getTm t of + PAlternative False _ -> 5 + _ -> 0 tacTm (PTactics _) = True tacTm (PProof _) = True @@ -431,9 +460,9 @@ setInjective (PApp _ (PRef _ n) _) = setinj n setInjective _ = return () - elab' ina@(_, a) tm@(PApp fc f [arg]) + elab' ina@(_, a, inty) tm@(PApp fc f [arg]) = erun fc $ - do simple_app (elabE ina f) (elabE (True, a) (getTm arg)) + do simple_app (elabE ina f) (elabE (True, a, inty) (getTm arg)) (show tm) solve elab' ina Placeholder = do (h : hs) <- get_holes @@ -442,7 +471,7 @@ do attack; defer n'; solve where mkN n@(NS _ _) = n mkN n = case namespace info of - Just xs@(_:_) -> NS n xs + Just xs@(_:_) -> sNS n xs _ -> n elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts elab' ina (PTactics ts) @@ -451,11 +480,11 @@ elab' ina (PElabError e) = fail (pshow ist e) elab' ina (PRewrite fc r sc newg) = do attack - tyn <- unique_hole (MN 0 "rty") + tyn <- getNameFrom (sMN 0 "rty") claim tyn RType - valn <- unique_hole (MN 0 "rval") + valn <- getNameFrom (sMN 0 "rval") claim valn (Var tyn) - letn <- unique_hole (MN 0 "rewrite_rule") + letn <- getNameFrom (sMN 0 "rewrite_rule") letbind letn (Var tyn) (Var valn) focus valn elab' ina r @@ -470,11 +499,11 @@ solve where doEquiv t sc = do attack - tyn <- unique_hole (MN 0 "ety") + tyn <- getNameFrom (sMN 0 "ety") claim tyn RType - valn <- unique_hole (MN 0 "eqval") + valn <- getNameFrom (sMN 0 "eqval") claim valn (Var tyn) - letn <- unique_hole (MN 0 "equiv_val") + letn <- getNameFrom (sMN 0 "equiv_val") letbind letn (Var tyn) (Var valn) focus tyn elab' ina t @@ -482,22 +511,25 @@ elab' ina sc elab' ina (PRef fc letn) solve - elab' ina@(_, a) c@(PCase fc scr opts) + elab' ina@(_, a, inty) c@(PCase fc scr opts) = do attack - tyn <- unique_hole (MN 0 "scty") + tyn <- getNameFrom (sMN 0 "scty") claim tyn RType - valn <- unique_hole (MN 0 "scval") - scvn <- unique_hole (MN 0 "scvar") + valn <- getNameFrom (sMN 0 "scval") + scvn <- getNameFrom (sMN 0 "scvar") claim valn (Var tyn) letbind scvn (Var tyn) (Var valn) focus valn - elabE (True, a) scr + elabE (True, a, inty) scr args <- get_env cname <- unique_hole' True (mkCaseName fn) let cname' = mkN cname elab' ina (PMetavar cname') + -- if the scrutinee is one of the 'args' in env, we should + -- inspect it directly, rather than adding it as a new argument let newdef = PClauses fc [] cname' - (caseBlock fc cname' (reverse args) opts) + (caseBlock fc cname' + (map (isScr scr) (reverse args)) opts) -- elaborate case env <- get_env updateAux (newdef : ) @@ -510,29 +542,54 @@ -- mkCaseName (MN i x) = MN i (x ++ "_case") mkN n@(NS _ _) = n mkN n = case namespace info of - Just xs@(_:_) -> NS n xs + Just xs@(_:_) -> sNS n xs _ -> n elab' ina (PUnifyLog t) = do unifyLog True elab' ina t unifyLog False elab' ina x = fail $ "Unelaboratable syntactic form " ++ show x - caseBlock :: FC -> Name -> [(Name, Binder Term)] -> - [(PTerm, PTerm)] -> [PClause] + isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term)) + isScr (PRef _ n) (n', b) = (n', (n == n', b)) + isScr _ (n', b) = (n', (False, b)) + + caseBlock :: FC -> Name -> + [(Name, (Bool, Binder Term))] -> [(PTerm, PTerm)] -> [PClause] caseBlock fc n env opts - = let args = map mkarg (map fst (init env)) in + = let args' = findScr env + args = map mkarg (map getNmScr args') in map (mkClause args) opts - where -- mkarg (MN _ _) = Placeholder - mkarg n = PRef fc n + + where -- Find the variable we want as the scrutinee and mark it as + -- 'True'. If the scrutinee is in the environment, match on that + -- otherwise match on the new argument we're adding. + findScr ((n, (True, t)) : xs) + = (n, (True, t)) : scrName n xs + findScr [(n, (_, t))] = [(n, (True, t))] + findScr (x : xs) = x : findScr xs + -- [] can't happen since scrutinee is in the environment! + + -- To make sure top level pattern name remains in scope, put + -- it at the end of the environment + scrName n [] = [] + scrName n [(_, t)] = [(n, t)] + scrName n (x : xs) = x : scrName n xs + + getNmScr (n, (s, _)) = (n, s) + + mkarg (n, s) = (PRef fc n, s) -- may be shadowed names in the new pattern - so replace the -- old ones with an _ mkClause args (l, r) = let args' = map (shadowed (allNamesIn l)) args lhs = PApp (getFC fc l) (PRef (getFC fc l) n) - (map pexp args' ++ [pexp l]) in + (map (mkLHSarg l) args') in PClause (getFC fc l) n lhs [] r [] - shadowed new (PRef _ n) | n `elem` new = Placeholder + mkLHSarg l (tm, True) = pexp l + mkLHSarg l (tm, False) = pexp tm + + shadowed new (PRef _ n, s) | n `elem` new = (Placeholder, s) shadowed new t = t getFC d (PApp fc _ _) = fc @@ -557,32 +614,75 @@ mkCoerce t n = let fc = fileFC "Coercion" in -- line never appears! addImpl ist (PApp fc (PRef fc n) [pexp (PCoerced t)]) - elabArgs ina failed fc retry [] _ + -- | Elaborate the arguments to a function + elabArgs :: IState -- ^ The current Idris state + -> (Bool, Bool, Bool) -- ^ (in an argument, guarded, in a type) + -> [Bool] + -> FC -- ^ Source location + -> Bool + -> Name -- ^ Name of the function being applied + -> [(Name, Name)] -- ^ (Argument Name, Hole Name) + -> [(Bool, PTerm)] -- ^ (Laziness, argument) + -> ElabD () + elabArgs ist ina failed fc retry f [] _ -- | retry = let (ns, ts) = unzip (reverse failed) in -- elabArgs ina [] False ns ts | otherwise = return () - elabArgs ina failed fc r (n:ns) ((_, Placeholder) : args) - = elabArgs ina failed fc r ns args - elabArgs ina failed fc r (n:ns) ((lazy, t) : args) + elabArgs ist ina failed fc r f (n:ns) ((_, Placeholder) : args) + = elabArgs ist ina failed fc r f ns args + elabArgs ist ina failed fc r f ((argName, holeName):ns) ((lazy, t) : args) | lazy && not pattern - = do elabArg n (PApp bi (PRef bi (UN "lazy")) - [pimp (UN "a") Placeholder True, - pexp t]); - | otherwise = elabArg n t - where elabArg n t - = do hs <- get_holes - tm <- get_term - failed' <- -- trace (show (n, t, hs, tm)) $ - -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $ - case n `elem` hs of - True -> --- if r --- then try (do focus n; elabE ina t; return failed) --- (return ((n,(lazy, t)):failed)) - do focus n; elabE ina t; return failed - False -> return failed - elabArgs ina failed fc r ns args + = elabArg argName holeName (PApp bi (PRef bi (sUN "lazy")) + [pimp (sUN "a") Placeholder True, + pexp t]) + | otherwise = elabArg argName holeName t + where elabArg argName holeName t = + reflectFunctionErrors ist f argName $ + do hs <- get_holes + tm <- get_term + failed' <- -- trace (show (n, t, hs, tm)) $ + -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $ + case holeName `elem` hs of + True -> do focus holeName; elabE ina t; return failed + False -> return failed + elabArgs ist ina failed fc r f ns args +-- | Perform error reflection for function applicaitons with specific error handlers +reflectFunctionErrors :: IState -> Name -> Name -> ElabD a -> ElabD a +reflectFunctionErrors ist f arg action = + do elabState <- get + (result, newState) <- case runStateT action elabState of + OK (res, newState) -> return (res, newState) + Error e@(ReflectionError _ _) -> (lift . tfail) e + Error e@(ReflectionFailed _ _) -> (lift . tfail) e + Error e -> handle e >>= lift . tfail + put newState + return result + where handle :: Err -> ElabD Err + handle e = do let funhandlers = (maybe M.empty id . lookupCtxtExact f . idris_function_errorhandlers) ist + handlers = (maybe [] S.toList . M.lookup arg) funhandlers + reports = map (\n -> RApp (Var n) (reflectErr e)) handlers + + + -- Typecheck error handlers - if this fails, then something else was wrong earlier! + handlers <- case mapM (check (tt_ctxt ist) []) reports of + Error e -> lift . tfail $ + ReflectionFailed "Type error while constructing reflected error" e + OK hs -> return hs + + -- Normalize error handler terms to produce the new messages + let ctxt = tt_ctxt ist + results = map (normalise ctxt []) (map fst handlers) + + -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent + let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results) + errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of + Left err -> lift (tfail err) + Right ok -> return ok + return $ case errorparts of + [] -> e + parts -> ReflectionError errorparts e + -- For every alternative, look at the function at the head. Automatically resolve -- any nested alternatives where that function is also at the head @@ -641,14 +741,14 @@ findInstances ist t | (P _ n _, _) <- unApply t = case lookupCtxt n (idris_classes ist) of - [CI _ _ _ _ ins] -> ins + [CI _ _ _ _ _ ins] -> ins _ -> [] | otherwise = [] trivial' ist - = trivial (elab ist toplevel False False (MN 0 "tac")) ist + = trivial (elab ist toplevel False [] (sMN 0 "tac")) ist proofSearch' ist top n hints - = proofSearch (elab ist toplevel False False (MN 0 "tac")) top n hints ist + = proofSearch (elab ist toplevel False [] (sMN 0 "tac")) top n hints ist resolveTC :: Int -> Term -> Name -> IState -> ElabD () @@ -658,9 +758,10 @@ = do hnf_compute g <- goal ptm <- get_term + ulog <- getUnifyLog hs <- get_holes - if True -- all (\n -> not (n `elem` hs)) (freeNames g) - then try' (trivial' ist) + traceWhen ulog ("Resolving class " ++ show g) $ + try' (trivial' ist) (do t <- goal let (tc, ttypes) = unApply t scopeOnly <- needsDefault t tc ttypes @@ -668,28 +769,23 @@ let insts = if scopeOnly then filter chaser insts_in else insts_in tm <- get_term --- traceWhen (depth > 6) ("GOAL: " ++ show t ++ "\nTERM: " ++ show tm) $ --- (tryAll (map elabTC (map fst (ctxtAlist (tt_ctxt ist))))) --- if scopeOnly then fail "Can't resolve" else let depth' = if scopeOnly then 2 else depth blunderbuss t depth' insts) True - else do try' (trivial' ist) - (do g <- goal - fail $ "Can't resolve " ++ show g) True --- tm <- get_term --- fail $ "Can't resolve yet in " ++ show tm where elabTC n | n /= fn && tcname n = (resolve n depth, show n) | otherwise = (fail "Can't resolve", show n) -- HACK! Rather than giving a special name, better to have some kind -- of flag in ClassInfo structure - chaser (UN ('@':'@':_)) = True -- old way + chaser (UN nm) + | ('@':'@':_) <- str nm = True -- old way chaser (SN (ParentN _ _)) = True chaser (NS n _) = chaser n chaser _ = False - needsDefault t num@(P _ (NS (UN "Num") ["Classes","Prelude"]) _) [P Bound a _] + numclass = sNS (sUN "Num") ["Classes","Prelude"] + + needsDefault t num@(P _ nc _) [P Bound a _] | nc == numclass = do focus a fill (RConstant (AType (ATInt ITBig))) -- default Integer solve @@ -722,8 +818,8 @@ [args] -> map isImp (snd args) -- won't be overloaded! ps <- get_probs tm <- get_term - args <- try' (match_apply (Var n) imps) - (apply (Var n) imps) True + args <- map snd <$> try' (apply (Var n) imps) + (match_apply (Var n) imps) True ps' <- get_probs when (length ps < length ps') $ fail "Can't apply type class" -- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $ @@ -735,7 +831,9 @@ (filter (\ (x, y) -> not x) (zip (map fst imps) args)) -- if there's any arguments left, we've failed to resolve hs <- get_holes + ulog <- getUnifyLog solve + traceWhen ulog ("Got " ++ show n) $ return () where isImp (PImp p _ _ _ _ _) = (True, p) isImp arg = (False, priority arg) @@ -762,7 +860,9 @@ runTac :: Bool -> IState -> PTactic -> ElabD () runTac autoSolve ist tac = do env <- get_env - no_errors $ runT (fmap (addImplBound ist (map fst env)) tac) + g <- goal + no_errors (runT (fmap (addImplBound ist (map fst env)) tac)) + (Just (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env))) where runT (Intro []) = do g <- goal attack; intro (bname g) @@ -777,7 +877,7 @@ where bname (Bind n _ _) = Just n bname _ = Nothing - runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm + runT (Exact tm) = do elab ist toplevel False [] (sMN 0 "tac") tm when autoSolve solveAll runT (MatchRefine fn) = do fnimps <- @@ -817,55 +917,59 @@ when autoSolve solveAll runT (Equiv tm) -- let bind tm, then = do attack - tyn <- unique_hole (MN 0 "ety") + tyn <- getNameFrom (sMN 0 "ety") claim tyn RType - valn <- unique_hole (MN 0 "eqval") + valn <- getNameFrom (sMN 0 "eqval") claim valn (Var tyn) - letn <- unique_hole (MN 0 "equiv_val") + letn <- getNameFrom (sMN 0 "equiv_val") letbind letn (Var tyn) (Var valn) focus tyn - elab ist toplevel False False (MN 0 "tac") tm + elab ist toplevel False [] (sMN 0 "tac") tm focus valn when autoSolve solveAll runT (Rewrite tm) -- to elaborate tm, let bind it, then rewrite by that = do attack; -- (h:_) <- get_holes - tyn <- unique_hole (MN 0 "rty") + tyn <- getNameFrom (sMN 0 "rty") -- start_unify h claim tyn RType - valn <- unique_hole (MN 0 "rval") + valn <- getNameFrom (sMN 0 "rval") claim valn (Var tyn) - letn <- unique_hole (MN 0 "rewrite_rule") + letn <- getNameFrom (sMN 0 "rewrite_rule") letbind letn (Var tyn) (Var valn) focus valn - elab ist toplevel False False (MN 0 "tac") tm + elab ist toplevel False [] (sMN 0 "tac") tm rewrite (Var letn) when autoSolve solveAll + runT (Induction nm) + = do induction nm + when autoSolve solveAll runT (LetTac n tm) = do attack - tyn <- unique_hole (MN 0 "letty") + tyn <- getNameFrom (sMN 0 "letty") claim tyn RType - valn <- unique_hole (MN 0 "letval") + valn <- getNameFrom (sMN 0 "letval") claim valn (Var tyn) letn <- unique_hole n letbind letn (Var tyn) (Var valn) focus valn - elab ist toplevel False False (MN 0 "tac") tm + elab ist toplevel False [] (sMN 0 "tac") tm when autoSolve solveAll runT (LetTacTy n ty tm) = do attack - tyn <- unique_hole (MN 0 "letty") + tyn <- getNameFrom (sMN 0 "letty") claim tyn RType - valn <- unique_hole (MN 0 "letval") + valn <- getNameFrom (sMN 0 "letval") claim valn (Var tyn) letn <- unique_hole n letbind letn (Var tyn) (Var valn) focus tyn - elab ist toplevel False False (MN 0 "tac") ty + elab ist toplevel False [] (sMN 0 "tac") ty focus valn - elab ist toplevel False False (MN 0 "tac") tm + elab ist toplevel False [] (sMN 0 "tac") tm when autoSolve solveAll runT Compute = compute runT Trivial = do trivial' ist; when autoSolve solveAll + runT TCInstance = runT (Exact (PResolveTC emptyFC)) runT (ProofSearch top n hints) = do proofSearch' ist top n hints; when autoSolve solveAll runT (Focus n) = focus n @@ -875,16 +979,16 @@ 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") + script <- getNameFrom (sMN 0 "script") claim script scriptTy - scriptvar <- unique_hole (MN 0 "scriptvar" ) + scriptvar <- getNameFrom (sMN 0 "scriptvar" ) letbind scriptvar scriptTy (Var script) focus script - elab ist toplevel False False (MN 0 "tac") tm + elab ist toplevel False [] (sMN 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") + restac <- getNameFrom (sMN 0 "restac") claim restac tacticTy focus restac fill (raw_apply (forget script') @@ -898,35 +1002,64 @@ 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") + listTy = Var (sNS (sUN "List") ["List", "Prelude"]) + scriptTy = (RBind (sUN "__pi_arg") (Pi (RApp listTy envTupleType)) - (RBind (UN "__pi_arg1") + (RBind (sUN "__pi_arg1") (Pi (Var $ reflm "TT")) tacticTy)) + runT (ByReflection tm) -- run the reflection function 'tm' on the + -- goal, then apply the resulting reflected Tactic + = do tgoal <- goal + attack + script <- getNameFrom (sMN 0 "script") + claim script scriptTy + scriptvar <- getNameFrom (sMN 0 "scriptvar" ) + letbind scriptvar scriptTy (Var script) + focus script + ptm <- get_term + elab ist toplevel False [] (sMN 0 "tac") + (PApp emptyFC tm [pexp (delabTy' ist [] tgoal True True)]) + (script', _) <- get_type_val (Var scriptvar) + -- now that we have the script apply + -- it to the reflected goal + restac <- getNameFrom (sMN 0 "restac") + claim restac tacticTy + focus restac + fill (forget script') + 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") + scriptTy = tacticTy runT (Reflect v) = do attack -- let x = reflect v in ... - tyn <- unique_hole (MN 0 "letty") + tyn <- getNameFrom (sMN 0 "letty") claim tyn RType - valn <- unique_hole (MN 0 "letval") + valn <- getNameFrom (sMN 0 "letval") claim valn (Var tyn) - letn <- unique_hole (MN 0 "letvar") + letn <- getNameFrom (sMN 0 "letvar") letbind letn (Var tyn) (Var valn) focus valn - elab ist toplevel False False (MN 0 "tac") v + elab ist toplevel False [] (sMN 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") + tyn <- getNameFrom (sMN 0 "letty") claim tyn RType - valn <- unique_hole (MN 0 "letval") + valn <- getNameFrom (sMN 0 "letval") claim valn (Var tyn) - letn <- unique_hole (MN 0 "letvar") + letn <- getNameFrom (sMN 0 "letvar") letbind letn (Var tyn) (Var valn) focus valn - elab ist toplevel False False (MN 0 "tac") v + elab ist toplevel False [] (sMN 0 "tac") v (value, _) <- get_type_val (Var letn) ctxt <- get_context env <- get_env @@ -936,26 +1069,27 @@ runT (GoalType n tac) = do g <- goal case unApply g of (P _ n' _, _) -> - if nsroot n' == UN n + if nsroot n' == sUN n then runT tac else fail "Wrong goal type" _ -> fail "Wrong goal type" runT ProofState = do g <- goal - trace (show g) $ return () + return () runT x = fail $ "Not implemented " ++ show x runReflected t = do t' <- reify ist t runTac autoSolve ist t' --- | Prefix a name with the "Reflection.Language" namespace +-- | Prefix a name with the "Language.Reflection" namespace reflm :: String -> Name -reflm n = NS (UN n) ["Reflection", "Language"] +reflm n = sNS (sUN n) ["Reflection", "Language"] -- | 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 "Instance" = return TCInstance reify _ (P _ n _) | n == reflm "Solve" = return Solve reify _ (P _ n _) | n == reflm "Compute" = return Compute reify ist t@(App _ _) @@ -971,7 +1105,7 @@ 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] + | t == reflm "Intro" = return $ Intro [sUN n] reifyApp ist t [t'] | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t') reifyApp ist t [t'] @@ -1056,19 +1190,19 @@ reifyRawApp t args = fail ("Unknown reflection raw term: " ++ show (t, args)) reifyTTName :: Term -> ElabD Name -reifyTTName t@(App _ _) +reifyTTName t | (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 + | t == reflm "UN" = return $ sUN n reifyTTNameApp t [n, ns] | t == reflm "NS" = do n' <- reifyTTName n ns' <- reifyTTNamespace ns - return $ NS n' ns' + return $ sNS n' ns' reifyTTNameApp t [Constant (I i), Constant (Str n)] - | t == reflm "MN" = return $ MN i n + | t == reflm "MN" = return $ sMN i n reifyTTNameApp t [] | t == reflm "NErased" = return NErased reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args)) @@ -1077,9 +1211,9 @@ reifyTTNamespace t@(App _ _) = case unApply t of (P _ f _, [Constant StrType]) - | f == NS (UN "Nil") ["List", "Prelude"] -> return [] + | f == sNS (sUN "Nil") ["List", "Prelude"] -> return [] (P _ f _, [Constant StrType, Constant (Str n), ns]) - | f == NS (UN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns) + | f == sNS (sUN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns) _ -> fail ("Unknown reflection namespace arg: " ++ show t) reifyTTNamespace t = fail ("Unknown reflection namespace arg: " ++ show t) @@ -1201,19 +1335,19 @@ = reflCall "TCon" [RConstant (I x), RConstant (I y)] reflectName :: Name -> Raw -reflectName (UN str) - = reflCall "UN" [RConstant (Str str)] +reflectName (UN s) + = reflCall "UN" [RConstant (Str (str s))] reflectName (NS n ns) = reflCall "NS" [ reflectName n , foldr (\ n s -> - raw_apply ( Var $ NS (UN "::") ["List", "Prelude"] ) + raw_apply ( Var $ sNS (sUN "::") ["List", "Prelude"] ) [ RConstant StrType, RConstant (Str n), s ]) - ( raw_apply ( Var $ NS (UN "Nil") ["List", "Prelude"] ) + ( raw_apply ( Var $ sNS (sUN "Nil") ["List", "Prelude"] ) [ RConstant StrType ]) - ns + (map str ns) ] reflectName (MN i n) - = reflCall "MN" [RConstant (I i), RConstant (Str n)] + = reflCall "MN" [RConstant (I i), RConstant (Str (str n))] reflectName (NErased) = Var (reflm "NErased") reflectName n = Var (reflm "NErased") -- special name, not yet implemented @@ -1270,7 +1404,7 @@ where consToEnvList :: (Name, Binder Term) -> Raw -> Raw consToEnvList (n, b) l - = raw_apply (Var (NS (UN "::") ["List", "Prelude"])) + = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"])) [ envTupleType , raw_apply (Var pairCon) [ (Var $ reflm "TTName") , (RApp (Var $ reflm "Binder") @@ -1282,15 +1416,187 @@ ] emptyEnvList :: Raw - emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"])) + emptyEnvList = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"])) [envTupleType] -- | Reflect an error into the internal datatype of Idris -- TODO +rawBool :: Bool -> Raw +rawBool True = Var (sNS (sUN "True") ["Bool", "Prelude"]) +rawBool False = Var (sNS (sUN "False") ["Bool", "Prelude"]) + +rawNil :: Raw -> Raw +rawNil ty = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"])) [ty] + +rawCons :: Raw -> Raw -> Raw -> Raw +rawCons ty hd tl = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"])) [ty, hd, tl] + +rawList :: Raw -> [Raw] -> Raw +rawList ty = foldr (rawCons ty) (rawNil ty) + +rawPairTy :: Raw -> Raw -> Raw +rawPairTy t1 t2 = raw_apply (Var pairTy) [t1, t2] + +rawPair :: (Raw, Raw) -> (Raw, Raw) -> Raw +rawPair (a, b) (x, y) = raw_apply (Var pairCon) [a, b, x, y] + +reflectCtxt :: [(Name, Type)] -> Raw +reflectCtxt ctxt = rawList (rawPairTy (Var $ reflm "TTName") (Var $ reflm "TT")) + (map (\ (n, t) -> (rawPair (Var $ reflm "TTName", Var $ reflm "TT") + (reflectName n, reflect t))) + ctxt) + reflectErr :: Err -> Raw -reflectErr (Msg msg) = raw_apply (Var (NS (UN "Msg") ["Reflection", "Language"])) [reflectConstant (Str msg)] -reflectErr (InternalMsg msg) = raw_apply (Var (NS (UN "InternalMsg") ["Reflection", "Language"])) [reflectConstant (Str msg)] -reflectErr x = trace ("Couldn't reflect error " ++ show x) raw_apply (Var (NS (UN "Msg") ["Reflection", "Language"])) [reflectConstant (Str $ show x)] +reflectErr (Msg msg) = raw_apply (Var $ reflErrName "Msg") [RConstant (Str msg)] +reflectErr (InternalMsg msg) = raw_apply (Var $ reflErrName "InternalMsg") [RConstant (Str msg)] +reflectErr (CantUnify b t1 t2 e ctxt i) = + raw_apply (Var $ reflErrName "CantUnify") + [ rawBool b + , reflect t1 + , reflect t2 + , reflectErr e + , reflectCtxt ctxt + , RConstant (I i)] +reflectErr (InfiniteUnify n tm ctxt) = + raw_apply (Var $ reflErrName "InfiniteUnify") + [ reflectName n + , reflect tm + , reflectCtxt ctxt + ] +reflectErr (CantConvert t t' ctxt) = + raw_apply (Var $ reflErrName "CantConvert") + [ reflect t + , reflect t' + , reflectCtxt ctxt + ] +reflectErr (CantSolveGoal t ctxt) = + raw_apply (Var $ reflErrName "CantSolveGoal") + [ reflect t + , reflectCtxt ctxt + ] +reflectErr (UnifyScope n n' t ctxt) = + raw_apply (Var $ reflErrName "UnifyScope") + [ reflectName n + , reflectName n' + , reflect t + , reflectCtxt ctxt + ] +reflectErr (CantInferType str) = + raw_apply (Var $ reflErrName "CantInferType") [RConstant (Str str)] +reflectErr (NonFunctionType t t') = + raw_apply (Var $ reflErrName "NonFunctionType") [reflect t, reflect t'] +reflectErr (NotEquality t t') = + raw_apply (Var $ reflErrName "NotEquality") [reflect t, reflect t'] +reflectErr (TooManyArguments n) = raw_apply (Var $ reflErrName "TooManyArguments") [reflectName n] +reflectErr (CantIntroduce t) = raw_apply (Var $ reflErrName "CantIntroduce") [reflect t] +reflectErr (NoSuchVariable n) = raw_apply (Var $ reflErrName "NoSuchVariable") [reflectName n] +reflectErr (NoTypeDecl n) = raw_apply (Var $ reflErrName "NoTypeDecl") [reflectName n] +reflectErr (NotInjective t1 t2 t3) = + raw_apply (Var $ reflErrName "NotInjective") + [ reflect t1 + , reflect t2 + , reflect t3 + ] +reflectErr (CantResolve t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t] +reflectErr (CantResolveAlts ss) = + raw_apply (Var $ reflErrName "CantResolve") + [rawList (Var $ (sUN "String")) (map (RConstant . Str) ss)] +reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t] +reflectErr UniverseError = Var $ reflErrName "UniverseError" +reflectErr ProgramLineComment = Var $ reflErrName "ProgramLineComment" +reflectErr (Inaccessible n) = raw_apply (Var $ reflErrName "Inaccessible") [reflectName n] +reflectErr (NonCollapsiblePostulate n) = raw_apply (Var $ reflErrName "NonCollabsiblePostulate") [reflectName n] +reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n] +reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e] +reflectErr (NoRewriting tm) = raw_apply (Var $ reflErrName "NoRewriting") [reflect tm] +reflectErr (At fc err) = raw_apply (Var $ reflErrName "At") [reflectFC fc, reflectErr err] + where reflectFC (FC source line col) = raw_apply (Var $ reflErrName "FileLoc") + [ RConstant (Str source) + , RConstant (I line) + , RConstant (I col) + ] +reflectErr (Elaborating str n e) = + raw_apply (Var $ reflErrName "Elaborating") + [ RConstant (Str str) + , reflectName n + , reflectErr e + ] +reflectErr (ProviderError str) = + raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)] +reflectErr (LoadingFailed str err) = + raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)] +reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x] + +withErrorReflection :: Idris a -> Idris a +withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror) + where handle :: Err -> Idris Err + handle e@(ReflectionError _ _) = do logLvl 3 "Skipping reflection of error reflection result" + return e -- Don't do meta-reflection of errors + handle e@(ReflectionFailed _ _) = do logLvl 3 "Skipping reflection of reflection failure" + return e + handle e = do ist <- getIState + logLvl 2 "Starting error reflection" + let handlers = idris_errorhandlers ist + logLvl 3 $ "Using reflection handlers " ++ concat (intersperse ", " (map show handlers)) + let reports = map (\n -> RApp (Var n) (reflectErr e)) handlers + + -- Typecheck error handlers - if this fails, then something else was wrong earlier! + handlers <- case mapM (check (tt_ctxt ist) []) reports of + Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e + OK hs -> return hs + + -- Normalize error handler terms to produce the new messages + ctxt <- getContext + let results = map (normalise ctxt []) (map fst handlers) + logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results)) + + -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent + let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results) + errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of + Left err -> ierror err + Right ok -> return ok + return $ case errorparts of + [] -> e + parts -> ReflectionError errorparts e + +fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a +fromTTMaybe (App (App (P (DCon _ _) (NS (UN just) _) _) ty) tm) + | just == txt "Just" = Just tm +fromTTMaybe x = Nothing + +reflErrName :: String -> Name +reflErrName n = sNS (sUN n) ["Errors", "Reflection", "Language"] + +-- | Attempt to reify a report part from TT to the internal +-- representation. Not in Idris or ElabD monads because it should be usable +-- from either. +reifyReportPart :: Term -> Either Err ErrorReportPart +reifyReportPart (App (P (DCon _ _) n _) (Constant (Str msg))) | n == reflErrName "TextPart" = + Right (TextPart msg) +reifyReportPart (App (P (DCon _ _) n _) ttn) + | n == reflErrName "NamePart" = + case runElab [] (reifyTTName ttn) (initElaborator NErased initContext Erased) of + Error e -> Left . InternalMsg $ + "could not reify name term " ++ + show ttn ++ + " when reflecting an error:" ++ show e + OK (n', _)-> Right $ NamePart n' +reifyReportPart (App (P (DCon _ _) n _) tm) + | n == reflErrName "TermPart" = + case runElab [] (reifyTT tm) (initElaborator NErased initContext Erased) of + Error e -> Left . InternalMsg $ + "could not reify reflected term " ++ + show tm ++ + " when reflecting an error:" ++ show e + OK (tm', _) -> Right $ TermPart tm' +reifyReportPart (App (P (DCon _ _) n _) tm) + | n == reflErrName "SubReport" = + case unList tm of + Just xs -> do subParts <- mapM reifyReportPart xs + Right (SubReport subParts) + Nothing -> Left . InternalMsg $ "could not reify subreport " ++ show tm +reifyReportPart x = Left . InternalMsg $ "could not reify " ++ show x + envTupleType :: Raw envTupleType = raw_apply (Var pairTy) [ (Var $ reflm "TTName") @@ -1298,45 +1604,4 @@ ] solveAll = try (do solve; solveAll) (return ()) - --- If the function application is specialisable, make a new --- top level function by normalising the application --- and elaborating the new expression. - -mkSpecialised :: IState -> FC -> Name -> [PTerm] -> PTerm -> ElabD PTerm -mkSpecialised i fc n args def - = do let tm' = def - case lookupCtxt n (idris_statics i) of - [as] -> if (not (or as)) then return tm' else - mkSpecDecl i n (zip args as) tm' - _ -> return tm' - -mkSpecDecl :: IState -> Name -> [(PTerm, Bool)] -> PTerm -> ElabD PTerm -mkSpecDecl i n pargs tm' - = do t <- goal - g <- get_guess - let (f, args) = unApply g - let sargs = zip args (map snd pargs) - let staticArgs = map fst (filter (\ (_,x) -> x) sargs) - let ns = group (sort (concatMap staticFnNames staticArgs)) - let ntimes = map (\xs -> (head xs, length xs - 1)) ns - if (not (null ns)) then - do env <- get_env - let g' = g -- specialise ctxt env ntimes g - return tm' --- trace (show t ++ "\n" ++ --- show ntimes ++ "\n" ++ --- show (delab i g) ++ "\n" ++ show (delab i g')) $ return tm' -- TODO - else return tm' - where - ctxt = tt_ctxt i - cg = idris_callgraph i - - staticFnNames tm | (P _ f _, as) <- unApply tm - = if not (isFnName f ctxt) then [] - else case lookupCtxt f cg of - [ns] -> f : f : [] --(ns \\ [f]) - [] -> [f,f] - _ -> [] - staticFnNames _ = [] diff --git a/src/Idris/ErrReverse.hs b/src/Idris/ErrReverse.hs new file mode 100644 --- /dev/null +++ b/src/Idris/ErrReverse.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE PatternGuards #-} + +module Idris.ErrReverse where + +import Idris.AbsSyntax +import Idris.Core.TT +import Util.Pretty + +import Data.List +import Debug.Trace + +-- For display purposes, apply any 'error reversal' transformations so that +-- errors will be more readable + +errReverse :: IState -> Term -> Term +errReverse ist t = rewrite 5 (elideLambdas t) + where + + rewrite 0 t = t + rewrite n t = let t' = foldl applyRule t (reverse (idris_errRev ist)) in + if t == t' then t + else rewrite (n - 1) t' + + applyRule :: Term -> (Term, Term) -> Term + applyRule t (l, r) = applyNames [] t l r + + -- Assume pattern bindings match in l and r (if they don't just treat + -- the rule as invalid and return t) + + applyNames ns t (Bind n (PVar ty) scl) (Bind n' (PVar ty') scr) + | n == n' = applyNames (n : ns) t (instantiate (P Ref n ty) scl) + (instantiate (P Ref n' ty') scr) + | otherwise = t + applyNames ns t l r = matchTerm ns l r t + + matchTerm ns l r t + | Just nmap <- match ns l t = substNames nmap r + matchTerm ns l r (App f a) = let f' = matchTerm ns l r f + a' = matchTerm ns l r a in + App f' a' + matchTerm ns l r (Bind n b sc) = let b' = fmap (matchTerm ns l r) b + sc' = matchTerm ns l r sc in + Bind n b' sc' + matchTerm ns l r t = t + + match ns l t = do ms <- match' ns l t + combine (nub ms) + + -- If any duplicate mappings, it's a failure + combine [] = Just [] + combine ((x, t) : xs) + | Just _ <- lookup x xs = Nothing + | otherwise = do xs' <- combine xs + Just ((x, t) : xs') + + match' ns (P Ref n _) t | n `elem` ns = Just [(n, t)] + match' ns (App f a) (App f' a') = do fs <- match' ns f f' + as <- match' ns a a' + Just (fs ++ as) + -- no matching Binds, for now... + match' ns x y = if x == y then Just [] else Nothing + + -- if the term under a lambda is huge, there's no much point in showing + -- it as it won't be very enlightening. + + elideLambdas (App f a) = App (elideLambdas f) (elideLambdas a) + elideLambdas (Bind n (Lam t) sc) + | size sc > 100 = P Ref (sUN "...") Erased + elideLambdas (Bind n b sc) + = Bind n (fmap elideLambdas b) (elideLambdas sc) + elideLambdas t = t + diff --git a/src/Idris/Error.hs b/src/Idris/Error.hs --- a/src/Idris/Error.hs +++ b/src/Idris/Error.hs @@ -6,13 +6,13 @@ import Idris.AbsSyntax import Idris.Delaborate -import Core.TT -import Core.Typecheck -import Core.Constraints +import Idris.Core.TT +import Idris.Core.Typecheck +import Idris.Core.Constraints import System.Console.Haskeline import System.Console.Haskeline.MonadException -import Control.Monad.State +import Control.Monad.State.Strict import Control.Monad.Error (throwError, catchError) import System.IO.Error(isUserError, ioeGetErrorString) import Data.Char @@ -38,6 +38,7 @@ idrisCatch :: Idris a -> (Err -> Idris a) -> Idris a idrisCatch = catchError + setAndReport :: Err -> Idris () setAndReport e = do ist <- getIState let h = idris_outh ist @@ -71,3 +72,4 @@ getErrColumn :: Err -> Int getErrColumn (At (FC _ _ c) _) = c getErrColumn _ = 0 + diff --git a/src/Idris/Help.hs b/src/Idris/Help.hs --- a/src/Idris/Help.hs +++ b/src/Idris/Help.hs @@ -9,6 +9,7 @@ | ColourArg -- ^ The command is the colour-setting command | NoArg -- ^ No completion (yet!?) | SpecialHeaderArg -- ^ do not use + | ConsoleWidthArg -- ^ The width of the console instance Show CmdArg where show ExprArg = "" @@ -20,6 +21,7 @@ show ColourArg = "