packages feed

idris 0.9.17.1 → 0.9.18

raw patch · 289 files changed

+10588/−7908 lines, 289 filesdep +zip-archivedep ~annotated-wl-pprintdep ~directorydep ~filepathsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: zip-archive

Dependency ranges changed: annotated-wl-pprint, directory, filepath, lens

API changes (from Hackage documentation)

- IRTS.Lang: LAllocate :: PrimFn
- IRTS.Lang: LAppend :: IntTy -> Endianness -> PrimFn
- IRTS.Lang: LAppendBuffer :: PrimFn
- IRTS.Lang: LIdxVec :: NativeTy -> Int -> PrimFn
- IRTS.Lang: LMkVec :: NativeTy -> Int -> PrimFn
- IRTS.Lang: LNullPtr :: PrimFn
- IRTS.Lang: LPeek :: IntTy -> Endianness -> PrimFn
- IRTS.Lang: LReadFile :: PrimFn
- IRTS.Lang: LRegisterPtr :: PrimFn
- IRTS.Lang: LStdErr :: PrimFn
- IRTS.Lang: LStdIn :: PrimFn
- IRTS.Lang: LStdOut :: PrimFn
- IRTS.Lang: LUpdateVec :: NativeTy -> Int -> PrimFn
- IRTS.Lang: LVMPtr :: PrimFn
- IRTS.Lang: LWriteFile :: PrimFn
- Idris.AbsSyntaxTree: Codata :: DataOpt
- Idris.AbsSyntaxTree: DataErrRev :: DataOpt
- Idris.AbsSyntaxTree: DefaultCaseFun :: DataOpt
- Idris.AbsSyntaxTree: DefaultEliminator :: DataOpt
- Idris.AbsSyntaxTree: PEq :: FC -> PTerm -> PTerm -> PTerm -> PTerm -> PTerm
- Idris.AbsSyntaxTree: PRefl :: FC -> PTerm -> PTerm
- Idris.AbsSyntaxTree: PRunTactics :: FC -> PTerm -> PTerm
- Idris.AbsSyntaxTree: TI :: [Name] -> Bool -> DataOpts -> [Int] -> [Name] -> TypeInfo
- Idris.AbsSyntaxTree: codata :: TypeInfo -> Bool
- Idris.AbsSyntaxTree: con_names :: TypeInfo -> [Name]
- Idris.AbsSyntaxTree: data DataOpt
- Idris.AbsSyntaxTree: data TypeInfo
- Idris.AbsSyntaxTree: data_opts :: TypeInfo -> DataOpts
- Idris.AbsSyntaxTree: existsCon :: Name
- Idris.AbsSyntaxTree: instance Eq DataOpt
- Idris.AbsSyntaxTree: instance Show (Doc OutputAnnotation)
- Idris.AbsSyntaxTree: instance Show DataOpt
- Idris.AbsSyntaxTree: instance Show TypeInfo
- Idris.AbsSyntaxTree: instanceName :: ClassInfo -> Name
- Idris.AbsSyntaxTree: mutual_types :: TypeInfo -> [Name]
- Idris.AbsSyntaxTree: param_pos :: TypeInfo -> [Int]
- Idris.AbsSyntaxTree: type DataOpts = [DataOpt]
- Idris.Core.TT: B16V :: (Vector Word16) -> Const
- Idris.Core.TT: B32V :: (Vector Word32) -> Const
- Idris.Core.TT: B64V :: (Vector Word64) -> Const
- Idris.Core.TT: B8V :: (Vector Word8) -> Const
- Idris.Core.TT: BufferType :: Const
- Idris.Core.TT: ElabDebug :: (Maybe String) -> t -> [(Name, t, [(Name, Binder t)])] -> Err' t
- Idris.Core.TT: ITVec :: NativeTy -> Int -> IntTy
- Idris.Core.TT: ManagedPtrType :: Const
- Idris.Core.TT: PtrType :: Const
- Idris.DSL: expandDo :: DSL -> PTerm -> PTerm
- Idris.ElabTerm: ELHS :: ElabMode
- Idris.ElabTerm: ERHS :: ElabMode
- Idris.ElabTerm: ETyDecl :: ElabMode
- Idris.ElabTerm: ElabCtxt :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> ElabCtxt
- Idris.ElabTerm: ElabResult :: Term -> [(Name, (Int, Maybe Name, Type))] -> [PDecl] -> Context -> [(Name, FC, [PArg], Type)] -> ElabResult
- Idris.ElabTerm: build :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ElabResult
- Idris.ElabTerm: buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ElabResult
- Idris.ElabTerm: case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()
- Idris.ElabTerm: claimTT :: Name -> ElabD Name
- Idris.ElabTerm: collectDeferred :: Maybe Name -> Term -> State [(Name, (Int, Maybe Name, Type))] Term
- Idris.ElabTerm: data ElabCtxt
- Idris.ElabTerm: data ElabMode
- Idris.ElabTerm: data ElabResult
- Idris.ElabTerm: e_guarded :: ElabCtxt -> Bool
- Idris.ElabTerm: e_inarg :: ElabCtxt -> Bool
- Idris.ElabTerm: e_intype :: ElabCtxt -> Bool
- Idris.ElabTerm: e_isfn :: ElabCtxt -> Bool
- Idris.ElabTerm: e_nomatching :: ElabCtxt -> Bool
- Idris.ElabTerm: e_qq :: ElabCtxt -> Bool
- Idris.ElabTerm: elab :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
- Idris.ElabTerm: elaboratingArgErr :: [(Name, Name)] -> Err -> Err
- Idris.ElabTerm: envTupleType :: Raw
- Idris.ElabTerm: findInstances :: IState -> Term -> [Name]
- Idris.ElabTerm: fromTTMaybe :: Term -> Maybe Term
- Idris.ElabTerm: getUnmatchable :: Context -> Name -> [Bool]
- Idris.ElabTerm: goal_polymorphic :: ElabD Bool
- Idris.ElabTerm: initElabCtxt :: ElabCtxt
- Idris.ElabTerm: instance Eq ElabMode
- Idris.ElabTerm: mkList :: Raw -> [Raw] -> Raw
- Idris.ElabTerm: processTacticDecls :: [(Name, FC, [PArg], Type)] -> Idris ()
- Idris.ElabTerm: proofSearch' :: IState -> Bool -> Bool -> Int -> Bool -> Maybe Name -> Name -> [Name] -> StateT (ElabState EState) TC ()
- Idris.ElabTerm: pruneAlt :: [PTerm] -> [PTerm]
- Idris.ElabTerm: pruneByType :: [Name] -> Term -> Context -> [PTerm] -> [PTerm]
- Idris.ElabTerm: rawBool :: Bool -> Raw
- Idris.ElabTerm: rawCons :: Raw -> Raw -> Raw -> Raw
- Idris.ElabTerm: rawList :: Raw -> [Raw] -> Raw
- Idris.ElabTerm: rawNil :: Raw -> Raw
- Idris.ElabTerm: rawPair :: (Raw, Raw) -> (Raw, Raw) -> Raw
- Idris.ElabTerm: rawPairTy :: Raw -> Raw -> Raw
- Idris.ElabTerm: reflCall :: String -> [Raw] -> Raw
- Idris.ElabTerm: reflErrName :: String -> Name
- Idris.ElabTerm: reflect :: Term -> Raw
- Idris.ElabTerm: reflectBinder :: Binder Term -> Raw
- Idris.ElabTerm: reflectBinderQuote :: ([Name] -> a -> Raw) -> Name -> [Name] -> Binder a -> Raw
- Idris.ElabTerm: reflectBinderQuotePattern :: ([Name] -> a -> ElabD ()) -> [Name] -> Binder a -> ElabD ()
- Idris.ElabTerm: reflectConstant :: Const -> Raw
- Idris.ElabTerm: reflectCtxt :: [(Name, Type)] -> Raw
- Idris.ElabTerm: reflectEnv :: Env -> Raw
- Idris.ElabTerm: reflectErr :: Err -> Raw
- Idris.ElabTerm: reflectFC :: FC -> Raw
- Idris.ElabTerm: reflectName :: Name -> Raw
- Idris.ElabTerm: reflectNameQuotePattern :: Name -> ElabD ()
- Idris.ElabTerm: reflectNameType :: NameType -> Raw
- Idris.ElabTerm: reflectRaw :: Raw -> Raw
- Idris.ElabTerm: reflectRawQuote :: [Name] -> Raw -> Raw
- Idris.ElabTerm: reflectRawQuotePattern :: [Name] -> Raw -> ElabD ()
- Idris.ElabTerm: reflectTTQuote :: [Name] -> Term -> Raw
- Idris.ElabTerm: reflectTTQuotePattern :: [Name] -> Term -> ElabD ()
- Idris.ElabTerm: reflectUExp :: UExp -> Raw
- Idris.ElabTerm: reflectUniverse :: Universe -> Raw
- Idris.ElabTerm: reflm :: String -> Name
- Idris.ElabTerm: reify :: IState -> Term -> ElabD PTactic
- Idris.ElabTerm: reifyApp :: IState -> Name -> [Term] -> ElabD PTactic
- Idris.ElabTerm: reifyArithTy :: Term -> ElabD ArithTy
- Idris.ElabTerm: reifyIntTy :: Term -> ElabD IntTy
- Idris.ElabTerm: reifyNativeTy :: Term -> ElabD NativeTy
- Idris.ElabTerm: reifyRaw :: Term -> ElabD Raw
- Idris.ElabTerm: reifyRawApp :: Name -> [Term] -> ElabD Raw
- Idris.ElabTerm: reifyReportPart :: Term -> Either Err ErrorReportPart
- Idris.ElabTerm: reifyReportParts :: Term -> ElabD [ErrorReportPart]
- Idris.ElabTerm: reifyTT :: Term -> ElabD Term
- Idris.ElabTerm: reifyTTApp :: Name -> [Term] -> ElabD Term
- Idris.ElabTerm: reifyTTBinder :: (Term -> ElabD a) -> Name -> Term -> ElabD (Binder a)
- Idris.ElabTerm: reifyTTBinderApp :: (Term -> ElabD a) -> Name -> [Term] -> ElabD (Binder a)
- Idris.ElabTerm: reifyTTConst :: Term -> ElabD Const
- Idris.ElabTerm: reifyTTConstApp :: Name -> Term -> ElabD Const
- Idris.ElabTerm: reifyTTName :: Term -> ElabD Name
- Idris.ElabTerm: reifyTTNameApp :: Name -> [Term] -> ElabD Name
- Idris.ElabTerm: reifyTTNameType :: Term -> ElabD NameType
- Idris.ElabTerm: reifyTTNamespace :: Term -> ElabD [String]
- Idris.ElabTerm: reifyTTUExp :: Term -> ElabD UExp
- Idris.ElabTerm: reifyTyDecl :: Term -> ElabD RTyDecl
- Idris.ElabTerm: resTC' :: (Num a, Eq a) => [TT Name] -> Bool -> [Name] -> a -> Term -> Name -> IState -> StateT (ElabState EState) TC ()
- Idris.ElabTerm: resolveTC :: Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
- Idris.ElabTerm: resultCaseDecls :: ElabResult -> [PDecl]
- Idris.ElabTerm: resultContext :: ElabResult -> Context
- Idris.ElabTerm: resultMetavars :: ElabResult -> [(Name, (Int, Maybe Name, Type))]
- Idris.ElabTerm: resultTerm :: ElabResult -> Term
- Idris.ElabTerm: resultTyDecls :: ElabResult -> [(Name, FC, [PArg], Type)]
- Idris.ElabTerm: runTac :: Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
- Idris.ElabTerm: runTactical :: FC -> Env -> Term -> ElabD ()
- Idris.ElabTerm: solveAll :: Elab' aux ()
- Idris.ElabTerm: solveAuto :: IState -> Name -> Bool -> Name -> ElabD ()
- Idris.ElabTerm: solveAutos :: IState -> Name -> Bool -> ElabD ()
- Idris.ElabTerm: tacN :: String -> Name
- Idris.ElabTerm: trivial' :: IState -> ElabD ()
- Idris.ElabTerm: withErrorReflection :: Idris a -> Idris a
- Idris.IBC: IBCFile :: Word8 -> FilePath -> ![Name] -> ![(Bool, FilePath)] -> ![FilePath] -> ![(Name, [PArg])] -> ![FixDecl] -> ![(Name, [Bool])] -> ![(Name, ClassInfo)] -> ![(Bool, Name, Name)] -> ![(Name, DSL)] -> ![(Name, TypeInfo)] -> ![(Name, OptInfo)] -> ![Syntax] -> ![String] -> ![(Codegen, FilePath)] -> ![(Codegen, String)] -> ![(Codegen, String)] -> ![String] -> ![(Codegen, String)] -> ![(Name, Accessibility)] -> ![(Name, Totality)] -> ![(FC, String)] -> ![(Name, [FnOpt])] -> ![(Name, FnInfo)] -> ![(Name, CGInfo)] -> ![(Name, Def)] -> ![(Name, (Docstring DocTerm, [(Name, Docstring DocTerm)]))] -> ![(Name, Docstring DocTerm)] -> ![(Name, (Term, Term))] -> ![(Term, Term)] -> ![Name] -> ![(FilePath, Int, PTerm)] -> ![(Name, Name)] -> ![(Name, MetaInformation)] -> ![Name] -> ![(Name, Name, Name)] -> ![(Name, (Maybe Name, Int, Bool))] -> ![(Name, ([([Name], Term, Term)], [PTerm]))] -> ![Name] -> !(Maybe FC) -> ![(Name, Int)] -> ![Name] -> IBCFile
- Idris.IBC: bdecode :: Binary b => FilePath -> IO b
- Idris.IBC: bencode :: Binary a => FilePath -> a -> IO ()
- Idris.IBC: data IBCFile
- Idris.IBC: ibc :: IState -> IBCWrite -> IBCFile -> Idris IBCFile
- Idris.IBC: ibcVersion :: Word8
- Idris.IBC: ibc_access :: IBCFile -> ![(Name, Accessibility)]
- Idris.IBC: ibc_cg :: IBCFile -> ![(Name, CGInfo)]
- Idris.IBC: ibc_cgflags :: IBCFile -> ![(Codegen, String)]
- Idris.IBC: ibc_classes :: IBCFile -> ![(Name, ClassInfo)]
- Idris.IBC: ibc_coercions :: IBCFile -> ![Name]
- Idris.IBC: ibc_datatypes :: IBCFile -> ![(Name, TypeInfo)]
- Idris.IBC: ibc_defs :: IBCFile -> ![(Name, Def)]
- Idris.IBC: ibc_docstrings :: IBCFile -> ![(Name, (Docstring DocTerm, [(Name, Docstring DocTerm)]))]
- Idris.IBC: ibc_dsls :: IBCFile -> ![(Name, DSL)]
- Idris.IBC: ibc_dynamic_libs :: IBCFile -> ![String]
- Idris.IBC: ibc_errRev :: IBCFile -> ![(Term, Term)]
- Idris.IBC: ibc_errorhandlers :: IBCFile -> ![Name]
- Idris.IBC: ibc_exports :: IBCFile -> ![Name]
- Idris.IBC: ibc_fixes :: IBCFile -> ![FixDecl]
- Idris.IBC: ibc_flags :: IBCFile -> ![(Name, [FnOpt])]
- Idris.IBC: ibc_fninfo :: IBCFile -> ![(Name, FnInfo)]
- Idris.IBC: ibc_function_errorhandlers :: IBCFile -> ![(Name, Name, Name)]
- Idris.IBC: ibc_hdrs :: IBCFile -> ![(Codegen, String)]
- Idris.IBC: ibc_implicits :: IBCFile -> ![(Name, [PArg])]
- Idris.IBC: ibc_importdirs :: IBCFile -> ![FilePath]
- Idris.IBC: ibc_imports :: IBCFile -> ![(Bool, FilePath)]
- Idris.IBC: ibc_instances :: IBCFile -> ![(Bool, Name, Name)]
- Idris.IBC: ibc_keywords :: IBCFile -> ![String]
- Idris.IBC: ibc_libs :: IBCFile -> ![(Codegen, String)]
- Idris.IBC: ibc_lineapps :: IBCFile -> ![(FilePath, Int, PTerm)]
- Idris.IBC: ibc_metainformation :: IBCFile -> ![(Name, MetaInformation)]
- Idris.IBC: ibc_metavars :: IBCFile -> ![(Name, (Maybe Name, Int, Bool))]
- Idris.IBC: ibc_moduledocs :: IBCFile -> ![(Name, Docstring DocTerm)]
- Idris.IBC: ibc_namehints :: IBCFile -> ![(Name, Name)]
- Idris.IBC: ibc_objs :: IBCFile -> ![(Codegen, FilePath)]
- Idris.IBC: ibc_optimise :: IBCFile -> ![(Name, OptInfo)]
- Idris.IBC: ibc_parsedSpan :: IBCFile -> !(Maybe FC)
- Idris.IBC: ibc_patdefs :: IBCFile -> ![(Name, ([([Name], Term, Term)], [PTerm]))]
- Idris.IBC: ibc_postulates :: IBCFile -> ![Name]
- Idris.IBC: ibc_statics :: IBCFile -> ![(Name, [Bool])]
- Idris.IBC: ibc_syntax :: IBCFile -> ![Syntax]
- Idris.IBC: ibc_total :: IBCFile -> ![(Name, Totality)]
- Idris.IBC: ibc_totcheckfail :: IBCFile -> ![(FC, String)]
- Idris.IBC: ibc_transforms :: IBCFile -> ![(Name, (Term, Term))]
- Idris.IBC: ibc_usage :: IBCFile -> ![(Name, Int)]
- Idris.IBC: initIBC :: IBCFile
- Idris.IBC: instance Binary IBCFile
- Idris.IBC: mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile
- Idris.IBC: pAccess :: Bool -> [(Name, Accessibility)] -> Idris ()
- Idris.IBC: pCG :: [(Name, CGInfo)] -> Idris ()
- Idris.IBC: pCGFlags :: [(Codegen, String)] -> Idris ()
- Idris.IBC: pClasses :: [(Name, ClassInfo)] -> Idris ()
- Idris.IBC: pCoercions :: [Name] -> Idris ()
- Idris.IBC: pDSLs :: [(Name, DSL)] -> Idris ()
- Idris.IBC: pDatatypes :: [(Name, TypeInfo)] -> Idris ()
- Idris.IBC: pDefs :: Bool -> [Name] -> [(Name, Def)] -> Idris ()
- Idris.IBC: pDocs :: [(Name, (Docstring DocTerm, [(Name, Docstring DocTerm)]))] -> Idris ()
- Idris.IBC: pDyLibs :: [String] -> Idris ()
- Idris.IBC: pErrRev :: [(Term, Term)] -> Idris ()
- Idris.IBC: pErrorHandlers :: [Name] -> Idris ()
- Idris.IBC: pExports :: [Name] -> Idris ()
- Idris.IBC: pFixes :: [FixDecl] -> Idris ()
- Idris.IBC: pFlags :: [(Name, [FnOpt])] -> Idris ()
- Idris.IBC: pFnInfo :: [(Name, FnInfo)] -> Idris ()
- Idris.IBC: pFunctionErrorHandlers :: [(Name, Name, Name)] -> Idris ()
- Idris.IBC: pHdrs :: [(Codegen, String)] -> Idris ()
- Idris.IBC: pImportDirs :: [FilePath] -> Idris ()
- Idris.IBC: pImports :: [(Bool, FilePath)] -> Idris ()
- Idris.IBC: pImps :: [(Name, [PArg])] -> Idris ()
- Idris.IBC: pInstances :: [(Bool, Name, Name)] -> Idris ()
- Idris.IBC: pKeywords :: [String] -> Idris ()
- Idris.IBC: pLibs :: [(Codegen, String)] -> Idris ()
- Idris.IBC: pLineApps :: [(FilePath, Int, PTerm)] -> Idris ()
- Idris.IBC: pMDocs :: [(Name, Docstring DocTerm)] -> Idris ()
- Idris.IBC: pMetaInformation :: [(Name, MetaInformation)] -> Idris ()
- Idris.IBC: pMetavars :: [(Name, (Maybe Name, Int, Bool))] -> Idris ()
- Idris.IBC: pNameHints :: [(Name, Name)] -> Idris ()
- Idris.IBC: pObjs :: [(Codegen, FilePath)] -> Idris ()
- Idris.IBC: pOptimise :: [(Name, OptInfo)] -> Idris ()
- Idris.IBC: pParsedSpan :: Maybe FC -> Idris ()
- Idris.IBC: pPatdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))] -> Idris ()
- Idris.IBC: pPostulates :: [Name] -> Idris ()
- Idris.IBC: pStatics :: [(Name, [Bool])] -> Idris ()
- Idris.IBC: pSyntax :: [Syntax] -> Idris ()
- Idris.IBC: pTotCheckErr :: [(FC, String)] -> Idris ()
- Idris.IBC: pTotal :: [(Name, Totality)] -> Idris ()
- Idris.IBC: pTrans :: [(Name, (Term, Term))] -> Idris ()
- Idris.IBC: pUsage :: [(Name, Int)] -> Idris ()
- Idris.IBC: process :: Bool -> IBCFile -> FilePath -> Idris ()
- Idris.IBC: safeToEnum :: (Enum a, Bounded a, Integral int) => String -> int -> a
- Idris.IBC: sourcefile :: IBCFile -> FilePath
- Idris.IBC: symbols :: IBCFile -> ![Name]
- Idris.IBC: timestampOlder :: FilePath -> FilePath -> Idris ()
- Idris.IBC: ver :: IBCFile -> Word8
- Idris.ParseExpr: runTactics :: SyntaxInfo -> IdrisParser PTerm
+ IRTS.Lang: LExternal :: Name -> PrimFn
+ IRTS.System: getEnvFlags :: IO [String]
+ Idris.AbsSyntax: addAutoHint :: Name -> Name -> Idris ()
+ Idris.AbsSyntax: getAutoHints :: Name -> Idris [Name]
+ Idris.AbsSyntaxTree: AutoHint :: FnOpt
+ Idris.AbsSyntaxTree: Browse :: [String] -> Command
+ Idris.AbsSyntaxTree: DAccess :: Accessibility -> Directive
+ Idris.AbsSyntaxTree: DDefault :: Bool -> Directive
+ Idris.AbsSyntaxTree: DDynamicLibs :: [String] -> Directive
+ Idris.AbsSyntaxTree: DErrorHandlers :: Name -> Name -> [Name] -> Directive
+ Idris.AbsSyntaxTree: DFlag :: Codegen -> String -> Directive
+ Idris.AbsSyntaxTree: DFreeze :: Name -> Directive
+ Idris.AbsSyntaxTree: DHide :: Name -> Directive
+ Idris.AbsSyntaxTree: DInclude :: Codegen -> String -> Directive
+ Idris.AbsSyntaxTree: DLanguage :: LanguageExt -> Directive
+ Idris.AbsSyntaxTree: DLib :: Codegen -> String -> Directive
+ Idris.AbsSyntaxTree: DLink :: Codegen -> String -> Directive
+ Idris.AbsSyntaxTree: DLogging :: Integer -> Directive
+ Idris.AbsSyntaxTree: DNameHint :: Name -> [Name] -> Directive
+ Idris.AbsSyntaxTree: DUsed :: FC -> Name -> Name -> Directive
+ Idris.AbsSyntaxTree: ExactlyOne :: Bool -> PAltType
+ Idris.AbsSyntaxTree: FirstSuccess :: PAltType
+ Idris.AbsSyntaxTree: IBCAutoHint :: Name -> Name -> IBCWrite
+ Idris.AbsSyntaxTree: IBCExtern :: (Name, Int) -> IBCWrite
+ Idris.AbsSyntaxTree: PIfThenElse :: FC -> PTerm -> PTerm -> PTerm -> PTerm
+ Idris.AbsSyntaxTree: PQuoteName :: Name -> PTerm
+ Idris.AbsSyntaxTree: PRunElab :: FC -> PTerm -> PTerm
+ Idris.AbsSyntaxTree: RAddInstance :: Name -> Name -> RDeclInstructions
+ Idris.AbsSyntaxTree: RClausesInstrs :: Name -> [([Name], Term, Term)] -> RDeclInstructions
+ Idris.AbsSyntaxTree: RTyDeclInstrs :: Name -> FC -> [PArg] -> Type -> RDeclInstructions
+ Idris.AbsSyntaxTree: basename :: Name -> Name
+ Idris.AbsSyntaxTree: d_name_fc :: PData' t -> FC
+ Idris.AbsSyntaxTree: data Directive
+ Idris.AbsSyntaxTree: data PAltType
+ Idris.AbsSyntaxTree: data RDeclInstructions
+ Idris.AbsSyntaxTree: highlightSource :: FC -> OutputAnnotation -> ElabD ()
+ Idris.AbsSyntaxTree: highlighting :: EState -> [(FC, OutputAnnotation)]
+ Idris.AbsSyntaxTree: idris_autohints :: IState -> Ctxt [Name]
+ Idris.AbsSyntaxTree: idris_externs :: IState -> Set (Name, Int)
+ Idris.AbsSyntaxTree: instance Data PAltType
+ Idris.AbsSyntaxTree: instance Eq PAltType
+ Idris.AbsSyntaxTree: instance Typeable PAltType
+ Idris.AbsSyntaxTree: instanceCtorName :: ClassInfo -> Name
+ Idris.AbsSyntaxTree: sigmaCon :: Name
+ Idris.Core.Binary: instance Binary ConstraintFC
+ Idris.Core.Binary: instance Binary UConstraint
+ Idris.Core.DeepSeq: instance NFData ConstraintFC
+ Idris.Core.DeepSeq: instance NFData UConstraint
+ Idris.Core.Elaborate: get_datatypes :: Elab' aux (Ctxt TypeInfo)
+ Idris.Core.Elaborate: set_datatypes :: Ctxt TypeInfo -> Elab' aux ()
+ Idris.Core.ProofState: datatypes :: ProofState -> Ctxt TypeInfo
+ Idris.Core.ProofTerm: updsubst :: Eq n => n -> TT n -> TT n -> TT n
+ Idris.Core.TT: AnnNamespace :: [Text] -> (Maybe FilePath) -> OutputAnnotation
+ Idris.Core.TT: Codata :: DataOpt
+ Idris.Core.TT: Complete :: AppStatus n
+ Idris.Core.TT: DataErrRev :: DataOpt
+ Idris.Core.TT: DefaultCaseFun :: DataOpt
+ Idris.Core.TT: DefaultEliminator :: DataOpt
+ Idris.Core.TT: ElabScriptDebug :: (Maybe String) -> t -> [(Name, t, [(Name, Binder t)])] -> Err' t
+ Idris.Core.TT: ElabScriptStuck :: t -> Err' t
+ Idris.Core.TT: FileFC :: String -> FC
+ Idris.Core.TT: Holes :: [n] -> AppStatus n
+ Idris.Core.TT: MaybeHoles :: AppStatus n
+ Idris.Core.TT: MetaN :: Name -> Name -> SpecialName
+ Idris.Core.TT: NoFC :: FC
+ Idris.Core.TT: TI :: [Name] -> Bool -> DataOpts -> [Int] -> [Name] -> TypeInfo
+ Idris.Core.TT: _fc_end :: FC -> (Int, Int)
+ Idris.Core.TT: _fc_fname :: FC -> String
+ Idris.Core.TT: _fc_start :: FC -> (Int, Int)
+ Idris.Core.TT: codata :: TypeInfo -> Bool
+ Idris.Core.TT: con_names :: TypeInfo -> [Name]
+ Idris.Core.TT: data AppStatus n
+ Idris.Core.TT: data DataOpt
+ Idris.Core.TT: data TypeInfo
+ Idris.Core.TT: data_opts :: TypeInfo -> DataOpts
+ Idris.Core.TT: instance Data ConstraintFC
+ Idris.Core.TT: instance Data UConstraint
+ Idris.Core.TT: instance Data n => Data (AppStatus n)
+ Idris.Core.TT: instance Eq DataOpt
+ Idris.Core.TT: instance Eq n => Eq (AppStatus n)
+ Idris.Core.TT: instance Functor AppStatus
+ Idris.Core.TT: instance Ord n => Ord (AppStatus n)
+ Idris.Core.TT: instance Show DataOpt
+ Idris.Core.TT: instance Show NameOutput
+ Idris.Core.TT: instance Show OutputAnnotation
+ Idris.Core.TT: instance Show TextFormatting
+ Idris.Core.TT: instance Show TypeInfo
+ Idris.Core.TT: instance Show n => Show (AppStatus n)
+ Idris.Core.TT: instance Sized Universe
+ Idris.Core.TT: instance Typeable AppStatus
+ Idris.Core.TT: instance Typeable ConstraintFC
+ Idris.Core.TT: instance Typeable UConstraint
+ Idris.Core.TT: mutual_types :: TypeInfo -> [Name]
+ Idris.Core.TT: param_pos :: TypeInfo -> [Int]
+ Idris.Core.TT: spanFC :: FC -> FC -> FC
+ Idris.Core.TT: type DataOpts = [DataOpt]
+ Idris.Coverage: recoverableCoverage :: Context -> Err -> Bool
+ Idris.Coverage: validCoverageCase :: Context -> Err -> Bool
+ Idris.DSL: expandSugar :: DSL -> PTerm -> PTerm
+ Idris.DeepSeq: instance NFData PAltType
+ Idris.Directives: directiveAction :: Directive -> Idris ()
+ Idris.Directives: disambiguate :: Name -> Idris Name
+ Idris.Elab.Term: ELHS :: ElabMode
+ Idris.Elab.Term: ERHS :: ElabMode
+ Idris.Elab.Term: ETyDecl :: ElabMode
+ Idris.Elab.Term: ElabCtxt :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> ElabCtxt
+ Idris.Elab.Term: ElabResult :: Term -> [(Name, (Int, Maybe Name, Type))] -> [PDecl] -> Context -> [RDeclInstructions] -> [(FC, OutputAnnotation)] -> ElabResult
+ Idris.Elab.Term: build :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ElabResult
+ Idris.Elab.Term: buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ElabResult
+ Idris.Elab.Term: case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()
+ Idris.Elab.Term: collectDeferred :: Maybe Name -> [Name] -> Context -> Term -> State [(Name, (Int, Maybe Name, Type))] Term
+ Idris.Elab.Term: data ElabCtxt
+ Idris.Elab.Term: data ElabMode
+ Idris.Elab.Term: data ElabResult
+ Idris.Elab.Term: e_guarded :: ElabCtxt -> Bool
+ Idris.Elab.Term: e_inarg :: ElabCtxt -> Bool
+ Idris.Elab.Term: e_intype :: ElabCtxt -> Bool
+ Idris.Elab.Term: e_isfn :: ElabCtxt -> Bool
+ Idris.Elab.Term: e_nomatching :: ElabCtxt -> Bool
+ Idris.Elab.Term: e_qq :: ElabCtxt -> Bool
+ Idris.Elab.Term: elab :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
+ Idris.Elab.Term: elaboratingArgErr :: [(Name, Name)] -> Err -> Err
+ Idris.Elab.Term: findHighlight :: Name -> ElabD OutputAnnotation
+ Idris.Elab.Term: findInstances :: IState -> Term -> [Name]
+ Idris.Elab.Term: getUnmatchable :: Context -> Name -> [Bool]
+ Idris.Elab.Term: goal_polymorphic :: ElabD Bool
+ Idris.Elab.Term: initElabCtxt :: ElabCtxt
+ Idris.Elab.Term: instance Eq ElabMode
+ Idris.Elab.Term: processTacticDecls :: ElabInfo -> [RDeclInstructions] -> Idris ()
+ Idris.Elab.Term: proofSearch' :: IState -> Bool -> Bool -> Int -> Bool -> Maybe Name -> Name -> [Name] -> StateT (ElabState EState) TC ()
+ Idris.Elab.Term: pruneAlt :: [PTerm] -> [PTerm]
+ Idris.Elab.Term: pruneByType :: [Name] -> Term -> Context -> [PTerm] -> [PTerm]
+ Idris.Elab.Term: resTC' :: (Num a, Eq a) => [TT Name] -> Bool -> [Name] -> a -> Term -> Name -> IState -> StateT (ElabState EState) TC ()
+ Idris.Elab.Term: resolveTC :: Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
+ Idris.Elab.Term: resultCaseDecls :: ElabResult -> [PDecl]
+ Idris.Elab.Term: resultContext :: ElabResult -> Context
+ Idris.Elab.Term: resultHighlighting :: ElabResult -> [(FC, OutputAnnotation)]
+ Idris.Elab.Term: resultMetavars :: ElabResult -> [(Name, (Int, Maybe Name, Type))]
+ Idris.Elab.Term: resultTerm :: ElabResult -> Term
+ Idris.Elab.Term: resultTyDecls :: ElabResult -> [RDeclInstructions]
+ Idris.Elab.Term: runTac :: Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
+ Idris.Elab.Term: runTactical :: IState -> FC -> Env -> Term -> ElabD ()
+ Idris.Elab.Term: solveAll :: Elab' aux ()
+ Idris.Elab.Term: solveAuto :: IState -> Name -> Bool -> Name -> ElabD ()
+ Idris.Elab.Term: solveAutos :: IState -> Name -> Bool -> ElabD ()
+ Idris.Elab.Term: trivial' :: IState -> ElabD ()
+ Idris.Elab.Term: trivialHoles' :: [(Name, Int)] -> IState -> ElabD ()
+ Idris.Elab.Term: withErrorReflection :: Idris a -> Idris a
+ Idris.Elab.Type: elabExtern :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> FC -> FnOpts -> Name -> PTerm -> Idris ()
+ Idris.Elab.Value: elabExec :: FC -> PTerm -> PTerm
+ Idris.IBC: instance Binary PAltType
+ Idris.IdeMode: BrowseNS :: String -> IdeModeCommand
+ Idris.Output: sendHighlighting :: [(FC, OutputAnnotation)] -> Idris ()
+ Idris.ParseData: recordI :: IdrisParser DataOpts
+ Idris.ParseData: recordParameter :: SyntaxInfo -> IdrisParser (Name, FC, Plicity, PTerm)
+ Idris.ParseExpr: autoImplicit :: t -> Static -> SyntaxInfo -> StateT IState IdrisInnerParser PTerm
+ Idris.ParseExpr: defaultImplicit :: t -> Static -> SyntaxInfo -> StateT IState IdrisInnerParser PTerm
+ Idris.ParseExpr: explicitPi :: [ArgOpt] -> Static -> SyntaxInfo -> StateT IState IdrisInnerParser PTerm
+ Idris.ParseExpr: if_ :: SyntaxInfo -> IdrisParser PTerm
+ Idris.ParseExpr: implicitPi :: [ArgOpt] -> Static -> SyntaxInfo -> StateT IState IdrisInnerParser PTerm
+ Idris.ParseExpr: impossible :: IdrisParser PTerm
+ Idris.ParseExpr: namequote :: SyntaxInfo -> IdrisParser PTerm
+ Idris.ParseExpr: normalImplicit :: [ArgOpt] -> Static -> SyntaxInfo -> StateT IState IdrisInnerParser PTerm
+ Idris.ParseExpr: runElab :: SyntaxInfo -> IdrisParser PTerm
+ Idris.ParseExpr: unboundPi :: [ArgOpt] -> Static -> SyntaxInfo -> StateT IState IdrisInnerParser PTerm
+ Idris.ParseHelpers: class HasLastTokenSpan m
+ Idris.ParseHelpers: getLastTokenSpan :: HasLastTokenSpan m => m (Maybe FC)
+ Idris.ParseHelpers: instance [overlap ok] HasLastTokenSpan IdrisParser
+ Idris.ParseHelpers: operatorFC :: MonadicParsing m => m (String, FC)
+ Idris.ParseHelpers: reservedFC :: MonadicParsing m => String -> m FC
+ Idris.ParseHelpers: reservedOpFC :: MonadicParsing m => String -> m FC
+ Idris.Parser: ImportInfo :: Bool -> FilePath -> Maybe (String, FC) -> [Text] -> FC -> FC -> ImportInfo
+ Idris.Parser: data ImportInfo
+ Idris.Parser: import_location :: ImportInfo -> FC
+ Idris.Parser: import_modname_location :: ImportInfo -> FC
+ Idris.Parser: import_namespace :: ImportInfo -> [Text]
+ Idris.Parser: import_path :: ImportInfo -> FilePath
+ Idris.Parser: import_reexport :: ImportInfo -> Bool
+ Idris.Parser: import_rename :: ImportInfo -> Maybe (String, FC)
+ Idris.ProofSearch: trivialHoles :: [(Name, Int)] -> (PTerm -> ElabD ()) -> IState -> ElabD ()
+ Idris.REPL.Browse: namesInNS :: [String] -> Idris [Name]
+ Idris.REPL.Browse: namespacesInNS :: [String] -> Idris [[String]]
+ Idris.Reflection: RDatatype :: Name -> [RTyConArg] -> Raw -> [(Name, Raw)] -> RDatatype
+ Idris.Reflection: RDefineFun :: Name -> [RFunClause] -> RFunDefn
+ Idris.Reflection: RIndex :: Name -> Raw -> RTyConArg
+ Idris.Reflection: RMkFunClause :: Raw -> Raw -> RFunClause
+ Idris.Reflection: RMkImpossibleClause :: Raw -> RFunClause
+ Idris.Reflection: RParameter :: Name -> Raw -> RTyConArg
+ Idris.Reflection: buildDatatypes :: Context -> Ctxt TypeInfo -> Name -> [RDatatype]
+ Idris.Reflection: claimTT :: Name -> ElabD Name
+ Idris.Reflection: data RDatatype
+ Idris.Reflection: data RFunClause
+ Idris.Reflection: data RFunDefn
+ Idris.Reflection: data RTyConArg
+ Idris.Reflection: envTupleType :: Raw
+ Idris.Reflection: fromTTMaybe :: Term -> Maybe Term
+ Idris.Reflection: instance Show RArg
+ Idris.Reflection: instance Show RDatatype
+ Idris.Reflection: instance Show RFunClause
+ Idris.Reflection: instance Show RFunDefn
+ Idris.Reflection: instance Show RTyConArg
+ Idris.Reflection: instance Show RTyDecl
+ Idris.Reflection: mkList :: Raw -> [Raw] -> Raw
+ Idris.Reflection: rawBool :: Bool -> Raw
+ Idris.Reflection: rawCons :: Raw -> Raw -> Raw -> Raw
+ Idris.Reflection: rawList :: Raw -> [Raw] -> Raw
+ Idris.Reflection: rawNil :: Raw -> Raw
+ Idris.Reflection: rawPair :: (Raw, Raw) -> (Raw, Raw) -> Raw
+ Idris.Reflection: rawPairTy :: Raw -> Raw -> Raw
+ Idris.Reflection: reflCall :: String -> [Raw] -> Raw
+ Idris.Reflection: reflErrName :: String -> Name
+ Idris.Reflection: reflect :: Term -> Raw
+ Idris.Reflection: reflectBinder :: Binder Term -> Raw
+ Idris.Reflection: reflectBinderQuote :: ([Name] -> a -> Raw) -> Name -> [Name] -> Binder a -> Raw
+ Idris.Reflection: reflectBinderQuotePattern :: ([Name] -> a -> ElabD ()) -> [Name] -> Binder a -> ElabD ()
+ Idris.Reflection: reflectConstant :: Const -> Raw
+ Idris.Reflection: reflectCtxt :: [(Name, Type)] -> Raw
+ Idris.Reflection: reflectDatatype :: RDatatype -> Raw
+ Idris.Reflection: reflectEnv :: Env -> Raw
+ Idris.Reflection: reflectErr :: Err -> Raw
+ Idris.Reflection: reflectFC :: FC -> Raw
+ Idris.Reflection: reflectName :: Name -> Raw
+ Idris.Reflection: reflectNameQuotePattern :: Name -> ElabD ()
+ Idris.Reflection: reflectNameType :: NameType -> Raw
+ Idris.Reflection: reflectRaw :: Raw -> Raw
+ Idris.Reflection: reflectRawQuote :: [Name] -> Raw -> Raw
+ Idris.Reflection: reflectRawQuotePattern :: [Name] -> Raw -> ElabD ()
+ Idris.Reflection: reflectSpecialName :: SpecialName -> Raw
+ Idris.Reflection: reflectTTQuote :: [Name] -> Term -> Raw
+ Idris.Reflection: reflectTTQuotePattern :: [Name] -> Term -> ElabD ()
+ Idris.Reflection: reflectUExp :: UExp -> Raw
+ Idris.Reflection: reflectUniverse :: Universe -> Raw
+ Idris.Reflection: reflm :: String -> Name
+ Idris.Reflection: reify :: IState -> Term -> ElabD PTactic
+ Idris.Reflection: reifyApp :: IState -> Name -> [Term] -> ElabD PTactic
+ Idris.Reflection: reifyArithTy :: Term -> ElabD ArithTy
+ Idris.Reflection: reifyFunDefn :: Term -> ElabD RFunDefn
+ Idris.Reflection: reifyIntTy :: Term -> ElabD IntTy
+ Idris.Reflection: reifyNativeTy :: Term -> ElabD NativeTy
+ Idris.Reflection: reifyRaw :: Term -> ElabD Raw
+ Idris.Reflection: reifyRawApp :: Name -> [Term] -> ElabD Raw
+ Idris.Reflection: reifyReportPart :: Term -> Either Err ErrorReportPart
+ Idris.Reflection: reifyReportParts :: Term -> ElabD [ErrorReportPart]
+ Idris.Reflection: reifyTT :: Term -> ElabD Term
+ Idris.Reflection: reifyTTApp :: Name -> [Term] -> ElabD Term
+ Idris.Reflection: reifyTTBinder :: (Term -> ElabD a) -> Name -> Term -> ElabD (Binder a)
+ Idris.Reflection: reifyTTBinderApp :: (Term -> ElabD a) -> Name -> [Term] -> ElabD (Binder a)
+ Idris.Reflection: reifyTTConst :: Term -> ElabD Const
+ Idris.Reflection: reifyTTConstApp :: Name -> Term -> ElabD Const
+ Idris.Reflection: reifyTTName :: Term -> ElabD Name
+ Idris.Reflection: reifyTTNameApp :: Name -> [Term] -> ElabD Name
+ Idris.Reflection: reifyTTNameType :: Term -> ElabD NameType
+ Idris.Reflection: reifyTTNamespace :: Term -> ElabD [String]
+ Idris.Reflection: reifyTTUExp :: Term -> ElabD UExp
+ Idris.Reflection: reifyTyDecl :: Term -> ElabD RTyDecl
+ Idris.Reflection: tacN :: String -> Name
+ Idris.Reflection: tcArgName :: RTyConArg -> Name
+ Idris.Reflection: tcArgTy :: RTyConArg -> Raw
+ Util.System: readSource :: FilePath -> IO String
+ Util.System: setupBundledCC :: IO ()
+ Util.System: writeSource :: FilePath -> String -> IO ()
- Idris.AbsSyntax: addInstance :: Bool -> Name -> Name -> Idris ()
+ Idris.AbsSyntax: addInstance :: Bool -> Bool -> Name -> Name -> Idris ()
- Idris.AbsSyntax: aiFn :: Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -> [[Text]] -> [PArg] -> Either Err PTerm
+ Idris.AbsSyntax: aiFn :: Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -> FC -> [[Text]] -> [PArg] -> Either Err PTerm
- Idris.AbsSyntaxTree: CI :: Name -> [(Name, (FnOpts, PTerm))] -> [(Name, (Name, PDecl))] -> [PDecl] -> [Name] -> [Name] -> [Int] -> ClassInfo
+ Idris.AbsSyntaxTree: CI :: Name -> [(Name, (FnOpts, PTerm))] -> [(Name, (Name, PDecl))] -> [PDecl] -> [Name] -> [(Name, Bool)] -> [Int] -> ClassInfo
- Idris.AbsSyntaxTree: DoBind :: FC -> Name -> t -> PDo' t
+ Idris.AbsSyntaxTree: DoBind :: FC -> Name -> FC -> t -> PDo' t
- Idris.AbsSyntaxTree: DoLet :: FC -> Name -> t -> t -> PDo' t
+ Idris.AbsSyntaxTree: DoLet :: FC -> Name -> FC -> t -> t -> PDo' t
- Idris.AbsSyntaxTree: EState :: [PDecl] -> [Elab' EState ()] -> [(Name, FC, [PArg], Type)] -> EState
+ Idris.AbsSyntaxTree: EState :: [(Name, PDecl)] -> [(Int, Elab' EState ())] -> [RDeclInstructions] -> [(FC, OutputAnnotation)] -> EState
- Idris.AbsSyntaxTree: Execute :: Command
+ Idris.AbsSyntaxTree: Execute :: PTerm -> Command
- Idris.AbsSyntaxTree: IBCInstance :: Bool -> Name -> Name -> IBCWrite
+ Idris.AbsSyntaxTree: IBCInstance :: Bool -> Bool -> Name -> Name -> IBCWrite
- Idris.AbsSyntaxTree: IState :: Context -> Set ConstraintFC -> [FixDecl] -> Ctxt [PArg] -> Ctxt [Bool] -> Ctxt ClassInfo -> Ctxt DSL -> Ctxt OptInfo -> Ctxt TypeInfo -> Ctxt [Name] -> Ctxt ([([Name], Term, Term)], [PTerm]) -> Ctxt [FnOpt] -> Ctxt CGInfo -> Ctxt [Name] -> Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]) -> Ctxt (Docstring DocTerm) -> Ctxt TIData -> Ctxt FnInfo -> Ctxt [(Term, Term)] -> [(FC, Name)] -> [(FC, Name)] -> [(FC, String)] -> IOption -> Int -> [((FilePath, Int), PTerm)] -> [(Name, (Maybe Name, Int, Bool))] -> [Name] -> [(Term, Term)] -> SyntaxRules -> [String] -> [FilePath] -> [(Name, (Int, PrimFn))] -> [(Codegen, FilePath)] -> [(Codegen, String)] -> [(Codegen, String)] -> [(Codegen, String)] -> [(FilePath, Bool)] -> [(Name, [String])] -> Maybe FC -> [(FC, Err)] -> Maybe Name -> [Int] -> [Maybe Int] -> Maybe FC -> Maybe FC -> [(Name, Maybe Accessibility)] -> Accessibility -> Bool -> [IBCWrite] -> Maybe String -> [DynamicLib] -> [LanguageExt] -> OutputMode -> Bool -> ColourTheme -> [Name] -> (Int, Ctxt (Int, Name)) -> Ctxt (Map Name (Set Name)) -> Map [Text] [Text] -> ConsoleWidth -> Set Name -> [(Name, Int)] -> Maybe (Map Name [Name]) -> Maybe (Map Name [Name]) -> [Name] -> [Name] -> Map Name Name -> [Name] -> IState
+ Idris.AbsSyntaxTree: IState :: Context -> Set ConstraintFC -> [FixDecl] -> Ctxt [PArg] -> Ctxt [Bool] -> Ctxt ClassInfo -> Ctxt DSL -> Ctxt OptInfo -> Ctxt TypeInfo -> Ctxt [Name] -> Ctxt ([([Name], Term, Term)], [PTerm]) -> Ctxt [FnOpt] -> Ctxt CGInfo -> Ctxt [Name] -> Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]) -> Ctxt (Docstring DocTerm) -> Ctxt TIData -> Ctxt FnInfo -> Ctxt [(Term, Term)] -> Ctxt [Name] -> [(FC, Name)] -> [(FC, Name)] -> [(FC, String)] -> IOption -> Int -> [((FilePath, Int), PTerm)] -> [(Name, (Maybe Name, Int, Bool))] -> [Name] -> [(Term, Term)] -> SyntaxRules -> [String] -> [FilePath] -> [(Name, (Int, PrimFn))] -> [(Codegen, FilePath)] -> [(Codegen, String)] -> [(Codegen, String)] -> [(Codegen, String)] -> [(FilePath, Bool)] -> [(Name, [String])] -> Maybe FC -> [(FC, Err)] -> Maybe Name -> [Int] -> [Maybe Int] -> Maybe FC -> Maybe FC -> [(Name, Maybe Accessibility)] -> Accessibility -> Bool -> [IBCWrite] -> Maybe String -> [DynamicLib] -> [LanguageExt] -> OutputMode -> Bool -> ColourTheme -> [Name] -> (Int, Ctxt (Int, Name)) -> Ctxt (Map Name (Set Name)) -> Map [Text] [Text] -> ConsoleWidth -> Set Name -> Set (Name, Int) -> [(Name, Int)] -> Maybe (Map Name [Name]) -> Maybe (Map Name [Name]) -> [Name] -> [Name] -> Map Name Name -> [Name] -> IState
- Idris.AbsSyntaxTree: PAlternative :: Bool -> [PTerm] -> PTerm
+ Idris.AbsSyntaxTree: PAlternative :: PAltType -> [PTerm] -> PTerm
- Idris.AbsSyntaxTree: PClass :: (Docstring (Either Err PTerm)) -> SyntaxInfo -> FC -> [(Name, t)] -> Name -> [(Name, t)] -> [(Name, Docstring (Either Err PTerm))] -> [Name] -> [PDecl' t] -> PDecl' t
+ Idris.AbsSyntaxTree: PClass :: (Docstring (Either Err PTerm)) -> SyntaxInfo -> FC -> [(Name, t)] -> Name -> FC -> [(Name, FC, t)] -> [(Name, Docstring (Either Err PTerm))] -> [(Name, FC)] -> [PDecl' t] -> (Maybe (Name, FC)) -> (Docstring (Either Err PTerm)) -> PDecl' t
- Idris.AbsSyntaxTree: PConstant :: Const -> PTerm
+ Idris.AbsSyntaxTree: PConstant :: FC -> Const -> PTerm
- Idris.AbsSyntaxTree: PDatadecl :: Name -> t -> [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, t, FC, [Name])] -> PData' t
+ Idris.AbsSyntaxTree: PDatadecl :: Name -> FC -> t -> [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, t, FC, [Name])] -> PData' t
- Idris.AbsSyntaxTree: PDirective :: (Idris ()) -> PDecl' t
+ Idris.AbsSyntaxTree: PDirective :: Directive -> PDecl' t
- Idris.AbsSyntaxTree: PInstance :: (Docstring (Either Err PTerm)) -> [(Name, Docstring (Either Err PTerm))] -> SyntaxInfo -> FC -> [(Name, t)] -> Name -> [t] -> t -> (Maybe Name) -> [PDecl' t] -> PDecl' t
+ Idris.AbsSyntaxTree: PInstance :: (Docstring (Either Err PTerm)) -> [(Name, Docstring (Either Err PTerm))] -> SyntaxInfo -> FC -> [(Name, t)] -> Name -> FC -> [t] -> t -> (Maybe Name) -> [PDecl' t] -> PDecl' t
- Idris.AbsSyntaxTree: PLam :: FC -> Name -> PTerm -> PTerm -> PTerm
+ Idris.AbsSyntaxTree: PLam :: FC -> Name -> FC -> PTerm -> PTerm -> PTerm
- Idris.AbsSyntaxTree: PLaterdecl :: Name -> t -> PData' t
+ Idris.AbsSyntaxTree: PLaterdecl :: Name -> FC -> t -> PData' t
- Idris.AbsSyntaxTree: PLet :: FC -> Name -> PTerm -> PTerm -> PTerm -> PTerm
+ Idris.AbsSyntaxTree: PLet :: FC -> Name -> FC -> PTerm -> PTerm -> PTerm -> PTerm
- Idris.AbsSyntaxTree: PMetavar :: Name -> PTerm
+ Idris.AbsSyntaxTree: PMetavar :: FC -> Name -> PTerm
- Idris.AbsSyntaxTree: PNamespace :: String -> [PDecl' t] -> PDecl' t
+ Idris.AbsSyntaxTree: PNamespace :: String -> FC -> [PDecl' t] -> PDecl' t
- Idris.AbsSyntaxTree: PPi :: Plicity -> Name -> PTerm -> PTerm -> PTerm
+ Idris.AbsSyntaxTree: PPi :: Plicity -> Name -> FC -> PTerm -> PTerm -> PTerm
- Idris.AbsSyntaxTree: PPostulate :: (Docstring (Either Err PTerm)) -> SyntaxInfo -> FC -> FnOpts -> Name -> t -> PDecl' t
+ Idris.AbsSyntaxTree: PPostulate :: Bool -> (Docstring (Either Err PTerm)) -> SyntaxInfo -> FC -> FnOpts -> Name -> t -> PDecl' t
- Idris.AbsSyntaxTree: PRecord :: (Docstring (Either Err PTerm)) -> SyntaxInfo -> FC -> Name -> t -> DataOpts -> (Docstring (Either Err PTerm)) -> Name -> t -> PDecl' t
+ Idris.AbsSyntaxTree: PRecord :: (Docstring (Either Err PTerm)) -> SyntaxInfo -> FC -> DataOpts -> Name -> FC -> [(Name, FC, Plicity, t)] -> [(Name, Docstring (Either Err PTerm))] -> [(Maybe (Name, FC), Plicity, t, Maybe (Docstring (Either Err PTerm)))] -> (Maybe (Name, FC)) -> (Docstring (Either Err PTerm)) -> SyntaxInfo -> PDecl' t
- Idris.AbsSyntaxTree: PTy :: (Docstring (Either Err PTerm)) -> [(Name, Docstring (Either Err PTerm))] -> SyntaxInfo -> FC -> FnOpts -> Name -> t -> PDecl' t
+ Idris.AbsSyntaxTree: PTy :: (Docstring (Either Err PTerm)) -> [(Name, Docstring (Either Err PTerm))] -> SyntaxInfo -> FC -> FnOpts -> Name -> FC -> t -> PDecl' t
- Idris.AbsSyntaxTree: PType :: PTerm
+ Idris.AbsSyntaxTree: PType :: FC -> PTerm
- Idris.AbsSyntaxTree: PWith :: FC -> Name -> t -> [t] -> t -> (Maybe Name) -> [PDecl' t] -> PClause' t
+ Idris.AbsSyntaxTree: PWith :: FC -> Name -> t -> [t] -> t -> (Maybe (Name, FC)) -> [PDecl' t] -> PClause' t
- Idris.AbsSyntaxTree: PWithR :: FC -> [t] -> t -> (Maybe Name) -> [PDecl' t] -> PClause' t
+ Idris.AbsSyntaxTree: PWithR :: FC -> [t] -> t -> (Maybe (Name, FC)) -> [PDecl' t] -> PClause' t
- Idris.AbsSyntaxTree: case_decls :: EState -> [PDecl]
+ Idris.AbsSyntaxTree: case_decls :: EState -> [(Name, PDecl)]
- Idris.AbsSyntaxTree: class_instances :: ClassInfo -> [Name]
+ Idris.AbsSyntaxTree: class_instances :: ClassInfo -> [(Name, Bool)]
- Idris.AbsSyntaxTree: d_cons :: PData' t -> [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, t, FC, [Name])]
+ Idris.AbsSyntaxTree: d_cons :: PData' t -> [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, t, FC, [Name])]
- Idris.AbsSyntaxTree: delayed_elab :: EState -> [Elab' EState ()]
+ Idris.AbsSyntaxTree: delayed_elab :: EState -> [(Int, Elab' EState ())]
- Idris.AbsSyntaxTree: new_tyDecls :: EState -> [(Name, FC, [PArg], Type)]
+ Idris.AbsSyntaxTree: new_tyDecls :: EState -> [RDeclInstructions]
- Idris.Core.Elaborate: elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)
+ Idris.Core.Elaborate: elaborate :: Context -> Ctxt TypeInfo -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)
- Idris.Core.Elaborate: handleError :: (Err -> Bool) -> Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
+ Idris.Core.Elaborate: handleError :: (Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
- Idris.Core.Elaborate: initElaborator :: Name -> Context -> Type -> ProofState
+ Idris.Core.Elaborate: initElaborator :: Name -> Context -> Ctxt TypeInfo -> Type -> ProofState
- Idris.Core.Evaluate: lookupP_all :: Bool -> Name -> Context -> [Term]
+ Idris.Core.Evaluate: lookupP_all :: Bool -> Bool -> Name -> Context -> [Term]
- Idris.Core.ProofState: PS :: Name -> [Name] -> [Name] -> Int -> ProofTerm -> Type -> [Name] -> (Name, [(Name, Term)]) -> [(Name, Term)] -> [(Name, [Name])] -> Maybe (Name, Term) -> Fails -> [Name] -> [Name] -> [Name] -> [(Name, [Name])] -> Maybe ProofState -> Context -> String -> Bool -> Bool -> [Name] -> [FailContext] -> ProofState
+ Idris.Core.ProofState: PS :: Name -> [Name] -> [Name] -> Int -> ProofTerm -> Type -> [Name] -> (Name, [(Name, Term)]) -> [(Name, Term)] -> [(Name, [Name])] -> Maybe (Name, Term) -> Fails -> [Name] -> [Name] -> [Name] -> [(Name, [Name])] -> Maybe ProofState -> Context -> Ctxt TypeInfo -> String -> Bool -> Bool -> [Name] -> [FailContext] -> ProofState
- Idris.Core.ProofState: newProof :: Name -> Context -> Type -> ProofState
+ Idris.Core.ProofState: newProof :: Name -> Context -> Ctxt TypeInfo -> Type -> ProofState
- Idris.Core.TT: App :: !(TT n) -> (TT n) -> TT n
+ Idris.Core.TT: App :: (AppStatus n) -> !(TT n) -> (TT n) -> TT n
- Idris.Core.TT: UniverseError :: Err' t
+ Idris.Core.TT: UniverseError :: FC -> UExp -> (Int, Int) -> (Int, Int) -> [ConstraintFC] -> Err' t
- Idris.Core.TT: prettyEnv :: (Pretty Const a, Pretty NameType a, Pretty a1 a, Show a1, Eq a1) => [(a1, Binder (TT a1))] -> TT a1 -> Doc a
+ Idris.Core.TT: prettyEnv :: Env -> Term -> Doc OutputAnnotation
- Idris.Delaborate: fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation
+ Idris.Delaborate: fancifyAnnots :: IState -> Bool -> OutputAnnotation -> OutputAnnotation
- Idris.Docs: ClassDoc :: Name -> d -> [FunDoc' d] -> [(Name, Maybe d)] -> [(Maybe Name, PTerm, (d, [(Name, d)]))] -> [PTerm] -> [PTerm] -> Docs' d
+ Idris.Docs: ClassDoc :: Name -> d -> [FunDoc' d] -> [(Name, Maybe d)] -> [(Maybe Name, PTerm, (d, [(Name, d)]))] -> [PTerm] -> [PTerm] -> (Maybe (FunDoc' d)) -> Docs' d
- Idris.Elab.Class: elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> FC -> [(Name, PTerm)] -> Name -> [(Name, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [Name] -> [PDecl] -> Idris ()
+ Idris.Elab.Class: elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> FC -> [(Name, PTerm)] -> Name -> FC -> [(Name, FC, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [(Name, FC)] -> [PDecl] -> Maybe (Name, FC) -> Docstring (Either Err PTerm) -> Idris ()
- Idris.Elab.Instance: elabInstance :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] -> ElabWhat -> FC -> [(Name, PTerm)] -> Name -> [PTerm] -> PTerm -> Maybe Name -> [PDecl] -> Idris ()
+ Idris.Elab.Instance: elabInstance :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] -> ElabWhat -> FC -> [(Name, PTerm)] -> Name -> FC -> [PTerm] -> PTerm -> Maybe Name -> [PDecl] -> Idris ()
- Idris.Elab.Record: elabRecord :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> FC -> Name -> PTerm -> DataOpts -> Docstring (Either Err PTerm) -> Name -> PTerm -> Idris ()
+ Idris.Elab.Record: elabRecord :: ElabInfo -> (Docstring (Either Err PTerm)) -> SyntaxInfo -> FC -> DataOpts -> Name -> FC -> [(Name, FC, Plicity, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [(Maybe (Name, FC), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> Maybe (Name, FC) -> (Docstring (Either Err PTerm)) -> SyntaxInfo -> Idris ()
- Idris.Elab.Type: elabType :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] -> FC -> FnOpts -> Name -> PTerm -> Idris Type
+ Idris.Elab.Type: elabType :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] -> FC -> FnOpts -> Name -> FC -> PTerm -> Idris Type
- Idris.Elab.Type: elabType' :: Bool -> ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] -> FC -> FnOpts -> Name -> PTerm -> Idris Type
+ Idris.Elab.Type: elabType' :: Bool -> ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] -> FC -> FnOpts -> Name -> FC -> PTerm -> Idris Type
- Idris.Elab.Utils: getParamsInType :: IState -> [Name] -> [PArg' t] -> TT Name -> [Name]
+ Idris.Elab.Utils: getParamsInType :: IState -> [Name] -> [PArg] -> Type -> [Name]
- Idris.ParseData: constructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name])
+ Idris.ParseData: constructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name])
- Idris.ParseData: simpleConstructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, [PTerm], FC, [Name])
+ Idris.ParseData: simpleConstructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, [PTerm], FC, [Name])
- Idris.ParseExpr: bracketed' :: SyntaxInfo -> IdrisParser PTerm
+ Idris.ParseExpr: bracketed' :: FC -> SyntaxInfo -> IdrisParser PTerm
- Idris.ParseExpr: constant :: IdrisParser Const
+ Idris.ParseExpr: constant :: IdrisParser (Const, FC)
- Idris.ParseExpr: constraintList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]
+ Idris.ParseExpr: constraintList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]
- Idris.ParseExpr: constraintList1 :: SyntaxInfo -> IdrisParser [(Name, PTerm)]
+ Idris.ParseExpr: constraintList1 :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]
- Idris.ParseExpr: tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]
+ Idris.ParseExpr: tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]
- Idris.ParseExpr: typeDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]
+ Idris.ParseExpr: typeDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]
- Idris.ParseExpr: verbatimStringLiteral :: MonadicParsing m => m String
+ Idris.ParseExpr: verbatimStringLiteral :: MonadicParsing m => m (String, FC)
- Idris.ParseHelpers: bindList :: (Name -> PTerm -> PTerm -> PTerm) -> [(Name, PTerm)] -> PTerm -> PTerm
+ Idris.ParseHelpers: bindList :: (Name -> FC -> PTerm -> PTerm -> PTerm) -> [(Name, FC, PTerm)] -> PTerm -> PTerm
- Idris.ParseHelpers: charLiteral :: MonadicParsing m => m Char
+ Idris.ParseHelpers: charLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (Char, FC)
- Idris.ParseHelpers: float :: MonadicParsing m => m Double
+ Idris.ParseHelpers: float :: (MonadicParsing m, HasLastTokenSpan m) => m (Double, FC)
- Idris.ParseHelpers: iName :: MonadicParsing m => [String] -> m Name
+ Idris.ParseHelpers: iName :: (MonadicParsing m, HasLastTokenSpan m) => [String] -> m (Name, FC)
- Idris.ParseHelpers: identifier :: MonadicParsing m => m String
+ Idris.ParseHelpers: identifier :: MonadicParsing m => m (String, FC)
- Idris.ParseHelpers: maybeWithNS :: MonadicParsing m => m String -> Bool -> [String] -> m Name
+ Idris.ParseHelpers: maybeWithNS :: (MonadicParsing m, HasLastTokenSpan m) => m (String, FC) -> Bool -> [String] -> m (Name, FC)
- Idris.ParseHelpers: name :: IdrisParser Name
+ Idris.ParseHelpers: name :: IdrisParser (Name, FC)
- Idris.ParseHelpers: natural :: MonadicParsing m => m Integer
+ Idris.ParseHelpers: natural :: (MonadicParsing m, HasLastTokenSpan m) => m (Integer, FC)
- Idris.ParseHelpers: stringLiteral :: MonadicParsing m => m String
+ Idris.ParseHelpers: stringLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (String, FC)
- Idris.ParseOps: fnName :: IdrisParser Name
+ Idris.ParseOps: fnName :: IdrisParser (Name, FC)
- Idris.ParseOps: operatorFront :: IdrisParser Name
+ Idris.ParseOps: operatorFront :: IdrisParser (Name, FC)
- Idris.Parser: classBlock :: SyntaxInfo -> IdrisParser [PDecl]
+ Idris.Parser: classBlock :: SyntaxInfo -> IdrisParser (Maybe (Name, FC), Docstring (Either Err PTerm), [PDecl])
- Idris.Parser: import_ :: IdrisParser (Bool, String, Maybe String, FC)
+ Idris.Parser: import_ :: IdrisParser ImportInfo
- Idris.Parser: moduleHeader :: IdrisParser (Maybe (Docstring ()), [String])
+ Idris.Parser: moduleHeader :: IdrisParser (Maybe (Docstring ()), [String], [(FC, OutputAnnotation)])
- Idris.Parser: parseImports :: FilePath -> String -> Idris (Maybe (Docstring ()), [String], [(Bool, String, Maybe String, FC)], Maybe Delta)
+ Idris.Parser: parseImports :: FilePath -> String -> Idris (Maybe (Docstring ()), [String], [ImportInfo], Maybe Delta)

Files

Setup.hs view
@@ -62,7 +62,7 @@   case lookup (FlagName "execonly") (S.configConfigurationsFlags flags) of     Just True -> True     Just False -> False-    Nothing -> True+    Nothing -> False  isRelease :: S.ConfigFlags -> Bool isRelease flags =@@ -137,17 +137,33 @@                                     ++ "   dir <- getDataDir\n"                                     ++ "   return (dir ++ \"/\" ++ name)" +-- a module that has info about existence and location of a bundled toolchain+generateToolchainModule verbosity srcDir toolDir = do+    let commonContent = "module Tools_idris where\n\n"+    let toolContent = case toolDir of+                        Just dir -> "hasBundledToolchain = True\n" +++                                    "getToolchainDir = \"" ++ dir ++ "\"\n"+                        Nothing -> "hasBundledToolchain = False\n" +++                                   "getToolchainDir = \"\""+    let toolPath = srcDir </> "Tools_idris" Px.<.> "hs"+    createDirectoryIfMissingVerbose verbosity True srcDir+    rewriteFile toolPath (commonContent ++ toolContent)  idrisConfigure _ flags _ local = do-      configureRTS-      generateVersionModule verbosity (autogenModulesDir local) (isRelease (configFlags local))-      when (isFreestanding $ configFlags local) (do-                targetDir <- lookupEnv "IDRIS_INSTALL_DIR"+    configureRTS+    generateVersionModule verbosity (autogenModulesDir local) (isRelease (configFlags local))+    if (isFreestanding $ configFlags local)+        then (do+                toolDir <- lookupEnv "IDRIS_TOOLCHAIN_DIR"+                generateToolchainModule verbosity (autogenModulesDir local) toolDir+                targetDir <- lookupEnv "IDRIS_LIB_DIR"                 case targetDir of                      Just d -> generateTargetModule verbosity (autogenModulesDir local) d                      Nothing -> error $ "Trying to build freestanding without a target directory."-                                  ++ " Set it by defining IDRIS_INSTALL_DIR.")-   where+                                  ++ " Set it by defining IDRIS_LIB_DIR.")+        else+                generateToolchainModule verbosity (autogenModulesDir local) Nothing+    where       verbosity = S.fromFlag $ S.configVerbosity flags       version   = pkgVersion . package $ localPkgDescr local @@ -162,6 +178,7 @@   let verb = S.fromFlag (S.sDistVerbosity flags)   generateVersionModule verb ("src") True   generateTargetModule verb "src" "./libs"+  generateToolchainModule verb "src" Nothing   preSDist simpleUserHooks args flags  idrisPostSDist args flags desc lbi = do@@ -228,7 +245,7 @@ -- Main  -- Install libraries during both copy and install--- See http://hackage.haskell.org/trac/hackage/ticket/718+-- See https://github.com/haskell/cabal/issues/709 main = defaultMainWithHooks $ simpleUserHooks    { postClean = idrisClean    , postConf  = idrisConfigure
codegen/idris-c/Main.hs view
@@ -14,6 +14,8 @@  import Paths_idris +import Util.System+ data Opts = Opts { inputs :: [FilePath],                    interface :: Bool,                    output :: FilePath }@@ -31,7 +33,8 @@     process opts [] = opts  c_main :: Opts -> Idris ()-c_main opts = do elabPrims+c_main opts = do runIO setupBundledCC+                 elabPrims                  loadInputs (inputs opts) Nothing                  mainProg <- if interface opts                                  then liftM Just elabMain
idris.cabal view
@@ -1,5 +1,5 @@ Name:           idris-Version:        0.9.17.1+Version:        0.9.18 License:        BSD3 License-file:   LICENSE Author:         Edwin Brady@@ -114,6 +114,7 @@                        libs/contrib/Classes/*.idr                        libs/contrib/Control/*.idr                        libs/contrib/Control/Isomorphism/*.idr+		       libs/contrib/Control/Algebra/*.idr                        libs/contrib/Data/*.idr                        libs/contrib/Decidable/*.idr                        libs/contrib/Network/*.idr@@ -304,6 +305,15 @@                        test/reg061/run                        test/reg061/*.idr                        test/reg061/expected+                       test/reg062/run+                       test/reg062/*.idr+                       test/reg062/expected+                       test/reg063/run+                       test/reg063/*.idr+                       test/reg063/expected+                       test/reg064/run+                       test/reg064/*.idr+                       test/reg064/expected                         test/basic001/run                        test/basic001/*.idr@@ -342,11 +352,29 @@                        test/basic012/run                        test/basic012/*.idr                        test/basic012/expected+                       test/basic013/run+                       test/basic013/*.idr+                       test/basic013/expected -                       test/buffer001-disabled/*.idr-                       test/buffer001-disabled/run-                       test/buffer001-disabled/expected+                       test/bignum001/run+                       test/bignum001/*.idr+                       test/bignum001/expected+                       test/bignum002/run+                       test/bignum002/*.idr+                       test/bignum002/expected +                       test/classes001/*.idr+                       test/classes001/run+                       test/classes001/expected+                       test/classes001/input++                       test/corecords001/*.idr+                       test/corecords001/run+                       test/corecords001/expected+                       test/corecords002/*.idr+                       test/corecords002/run+                       test/corecords002/expected+                        test/delab001/*.idr                        test/delab001/run                        test/delab001/expected@@ -374,6 +402,10 @@                        test/effects003/*.idr                        test/effects003/expected                        test/effects003/input+                       test/effects004/run+                       test/effects004/*.idr+                       test/effects004/expected+                       test/effects004/input                         test/error001/run                        test/error001/*.idr@@ -414,6 +446,10 @@                        test/ffi006/run                        test/ffi006/expected +                       test/folding001/*.idr+                       test/folding001/run+                       test/folding001/expected+                        test/idrisdoc001/run                        test/idrisdoc001/expected                        test/idrisdoc001/*.idr@@ -495,6 +531,13 @@                        test/literate001/*.lidr                        test/literate001/expected +                       test/meta001/run+                       test/meta001/*.idr+                       test/meta001/expected+                       test/meta002/run+                       test/meta002/*.idr+                       test/meta002/expected+                        test/primitives001/run                        test/primitives001/*.idr                        test/primitives001/expected@@ -532,6 +575,9 @@                        test/proof009/*.idr                        test/proof009/expected                        test/proof009/input+                       test/proof010/run+                       test/proof010/*.idr+                       test/proof010/expected                         test/quasiquote001/run                        test/quasiquote001/*.idr@@ -548,7 +594,9 @@                        test/quasiquote005/run                        test/quasiquote005/*.idr                        test/quasiquote005/expected-+                       test/quasiquote006/run+                       test/quasiquote006/*.idr+                       test/quasiquote006/expected                         test/records001/run                        test/records001/*.idr@@ -609,6 +657,9 @@                        test/totality008/run                        test/totality008/*.idr                        test/totality008/expected+                       test/totality009/run+                       test/totality009/*.idr+                       test/totality009/expected                         test/tutorial001/run                        test/tutorial001/*.idr@@ -721,7 +772,10 @@                 , Idris.Elab.Provider                 , Idris.Elab.Transform                 , Idris.Elab.Value+                , Idris.Elab.Term +                , Idris.REPL.Browse+                 , Idris.AbsSyntax                 , Idris.AbsSyntaxTree                 , Idris.Apropos@@ -735,11 +789,11 @@                 , Idris.DataOpts                 , Idris.DeepSeq                 , Idris.Delaborate+                , Idris.Directives                 , Idris.Docs                 , Idris.Docstrings                 , Idris.ElabDecls                 , Idris.ElabQuasiquote-                , Idris.ElabTerm                 , Idris.Erasure                 , Idris.Error                 , Idris.ErrReverse@@ -801,9 +855,10 @@                 -- Auto Generated                 , Paths_idris                 , Version_idris+                , Tools_idris    Build-depends:  base >=4 && <5-                , annotated-wl-pprint >= 0.5.3 && < 0.6+                , annotated-wl-pprint >= 0.5.3 && < 0.7                 , ansi-terminal < 0.7                 , ansi-wl-pprint < 0.7                 , base64-bytestring < 1.1@@ -814,11 +869,11 @@                 , cheapskate < 0.2                 , containers >= 0.5 && < 0.6                 , deepseq < 1.5-                , directory >= 1.2 && < 1.3-                , filepath < 1.4+                , directory >= 1.2.2.0 && < 1.3+                , filepath < 1.5                 , fingertree >= 0.1 && < 0.2                 , haskeline >= 0.7 && < 0.8-                , lens >= 4.1.1 && < 4.8+                , lens >= 4.1.1 && < 4.10                 , mtl >= 2.1 && < 2.3                 , network < 2.7                 , optparse-applicative >= 0.11 && < 0.12@@ -837,6 +892,7 @@                 , vector < 0.11                 , vector-binary-instances < 0.3                 , xml < 1.4+                , zip-archive > 0.2.3.5 && < 0.2.4                 , zlib < 0.6                 , safe   Extensions:     MultiParamTypeClasses@@ -847,7 +903,7 @@                 , FlexibleInstances                 , TemplateHaskell -  ghc-prof-options: -auto-all -caf-all+--   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts    if os(linux)@@ -891,7 +947,7 @@                 , haskeline >= 0.7                 , transformers -  ghc-prof-options: -auto-all -caf-all+--   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -funbox-strict-fields  Executable idris-c@@ -904,7 +960,7 @@                 , haskeline >= 0.7                 , transformers -  ghc-prof-options: -auto-all -caf-all+--   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -funbox-strict-fields  Executable idris-javascript@@ -917,7 +973,7 @@                 , haskeline >= 0.7                 , transformers -  ghc-prof-options: -auto-all -caf-all+--   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -funbox-strict-fields -O2  Executable idris-node@@ -930,5 +986,5 @@                 , haskeline >= 0.7                 , transformers -  ghc-prof-options: -auto-all -caf-all+--   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -funbox-strict-fields -O2
libs/base/Control/Arrow.idr view
@@ -16,9 +16,7 @@   first  : arr a b -> arr (a, c) (b, c)    second : arr a b -> arr (c, a) (c, b)-  second f = arrow swap >>> first f >>> arrow swap where-    swap : (x,y) -> (y,x)-    swap (x,y) = (y,x)+  second f = arrow swap >>> first f >>> arrow swap    (***)  : arr a b -> arr a' b' -> arr (a, a') (b, b')   f *** g = first f >>> second g@@ -61,10 +59,7 @@   left  : arr a b -> arr (Either a c) (Either b c)    right : arr a b -> arr (Either c a) (Either c b)-  right f = arrow swap >>> left f >>> arrow swap where-    swap : Either a b -> Either b a-    swap (Left  x) = Right x-    swap (Right x) = Left x+  right f = arrow mirror >>> left f >>> arrow mirror    (+++) : arr a b -> arr c d -> arr (Either a c) (Either b d)   f +++ g = left f >>> right g
libs/base/Control/Isomorphism.idr view
@@ -39,13 +39,10 @@  ||| Disjunction is commutative eitherComm : Iso (Either a b) (Either b a)-eitherComm = MkIso swap swap swapSwap swapSwap-  where swap : Either a' b' -> Either b' a' -- a & b are parameters, so fixed!-        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+eitherComm = MkIso mirror mirror mirrorMirror mirrorMirror+  where mirrorMirror : (e : Either a' b') -> mirror (mirror e) = e+        mirrorMirror (Left x) = Refl+        mirrorMirror (Right x) = Refl  ||| Disjunction is associative eitherAssoc : Iso (Either (Either a b) c) (Either a (Either b c))@@ -116,10 +113,7 @@ ||| Conjunction is commutative 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+  where swapSwap : (x : (a', b')) -> swap (swap x) = x         swapSwap (x, y) = Refl  ||| Conjunction is associative
libs/base/Control/Monad/Identity.idr view
@@ -1,7 +1,8 @@ module Control.Monad.Identity -public record Identity : Type -> Type where-    Id : (runIdentity : a) -> Identity a+public record Identity (a : Type) where+  constructor Id+  runIdentity : a  instance Functor Identity where     map fn (Id a) = Id (fn a)
libs/base/Control/Monad/RWS.idr view
@@ -11,10 +11,10 @@ class (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m) => MonadRWS r w s (m : Type -> Type) where {}  ||| The transformer on which the RWS monad is based-record RWST : Type -> Type -> Type -> (Type -> Type) -> Type -> Type where-    MkRWST : {m : Type -> Type} ->-             (runRWST : r -> s -> m (a, s, w)) -> RWST r w s m a-+record RWST (r : Type) (w : Type) (s : Type) (m : Type -> Type) (a : Type) where+  constructor MkRWST+  runRWST : r -> s -> m (a, s, w)+   instance Monad m => Functor (RWST r w s m) where     map f (MkRWST m) = MkRWST $ \r,s => do  (a, s', w) <- m r s                                             return (f a, s', w)@@ -23,7 +23,7 @@     pure a = MkRWST $ \_,s => return (a, s, neutral)     (MkRWST f) <*> (MkRWST v) = MkRWST $ \r,s => do (a, s', w)   <- v r s                                                     (fn, ss, w') <- f r s-                                                    return (fn a, ss, w <+> w)+                                                    return (fn a, ss, w <+> w')  instance (Monoid w, Monad m) => Monad (RWST r w s m) where     (MkRWST m) >>= k = MkRWST $ \r,s => do  (a, s', w) <- m r s
libs/base/Control/Monad/Reader.idr view
@@ -14,9 +14,9 @@     local : (r -> r) -> m a -> m a  ||| The transformer on which the Reader monad is based-record ReaderT : Type -> (Type -> Type) -> Type -> Type where-    RD : {m : Type -> Type} ->-         (runReaderT : r -> m a) -> ReaderT r m a+record ReaderT (r : Type) (m : Type -> Type) (a : Type) where+  constructor RD+  runReaderT : r -> m a  ||| Create a ReaderT with an empty context liftReaderT : {m : Type -> Type} -> m a -> ReaderT r m a
libs/base/Control/Monad/State.idr view
@@ -1,6 +1,6 @@ module Control.Monad.State -import Control.Monad.Identity+import public Control.Monad.Identity import Control.Monad.Trans  %access public@@ -13,9 +13,9 @@     put : s -> m ()  ||| The transformer on which the State monad is based-record StateT : Type -> (Type -> Type) -> Type -> Type where-    ST : {m : Type -> Type} ->-         (runStateT : s -> m (a, s)) -> StateT s m a+record StateT (s : Type) (m : Type -> Type) (a : Type) where+  constructor ST+  runStateT : s -> m (a, s)  instance Functor f => Functor (StateT s f) where     map f (ST g) = ST (\st => map (mapFst f) (g st)) where@@ -55,3 +55,15 @@ ||| The State monad. See the MonadState class State : Type -> Type -> Type State s a = StateT s Identity a++||| Unwrap a State monad computation.+runState : StateT s Identity a -> s -> (a, s)+runState act = runIdentity . runStateT act++||| Unwrap a State monad computation, but discard the final state.+evalState : State s a -> s -> a+evalState m = fst . runState m++||| Unwrap a State monad computation, but discard the resulting value.+execState : State s a -> s -> s+execState m = snd . runState m
libs/base/Control/Monad/Writer.idr view
@@ -16,9 +16,9 @@     pass   : m (a, w -> w) -> m a  ||| The transformer base of the Writer monad-record WriterT : Type -> (Type -> Type) -> Type -> Type where-    WR : {m : Type -> Type} ->-         (runWriterT : m (a, w)) -> WriterT w m a+record WriterT (w : Type) (m : Type -> Type) (a : Type) where+  constructor WR+  runWriterT : m (a, w)  instance Functor f => Functor (WriterT w f) where     map f (WR g) = WR $ map (\w => (f . fst $ w, snd w)) g
libs/base/Data/Bits.idr view
@@ -4,21 +4,16 @@  %default total -divCeil : Nat -> Nat -> Nat-divCeil x y = case x `mod` y of-                Z   => x `div` y-                S _ => S (x `div` y)- nextPow2 : Nat -> Nat nextPow2 Z = Z-nextPow2 x = if x == (2 `power` l2x)-             then l2x-             else S l2x+nextPow2 (S x) = if (S x) == (2 `power` l2x)+               then l2x+               else S l2x     where-      l2x = log2 x+      l2x = log2NZ (S x) SIsNotZ  nextBytes : Nat -> Nat-nextBytes bits = (nextPow2 (bits `divCeil` 8))+nextBytes bits = (nextPow2 (divCeilNZ bits 8 SIsNotZ))  machineTy : Nat -> Type machineTy Z = Bits8
libs/base/Data/List.idr view
@@ -36,3 +36,16 @@                Elem x' (y' :: xs') -> Void         mkNo f g Here = f Refl         mkNo f g (There x) = g x++||| The intersectBy function returns the intersect of two lists by user-supplied equality predicate.+intersectBy : (a -> a -> Bool) -> List a -> List a -> List a+intersectBy eq xs ys = [x | x <- xs, any (eq x) ys]++||| Compute the intersection of two lists according to their `Eq` instance.+|||+||| ```idris example+||| intersect [1, 2, 3, 4] [2, 4, 6, 8]+||| ```+|||+intersect : (Eq a) => List a -> List a -> List a+intersect = intersectBy (==)
libs/base/Data/VectType.idr view
@@ -93,14 +93,14 @@ -- Subvectors -------------------------------------------------------------------------------- -||| Get the first m elements of a Vect-||| @ m the number of elements to take+||| Get the first n elements of a Vect+||| @ n the number of elements to take take : (n : Nat) -> Vect (n + m) a -> Vect n a take Z     xs        = [] take (S k) (x :: xs) = x :: take k xs -||| Remove the first m elements of a Vect-||| @ m the number of elements to remove+||| Remove the first n elements of a Vect+||| @ n the number of elements to remove drop : (n : Nat) -> Vect (n + m) a -> Vect m a drop Z     xs        = xs drop (S k) (x :: xs) = drop k xs@@ -372,14 +372,11 @@   | False = find p xs  ||| Find the index of the first element of the vector that satisfies some test-findIndex : (a -> Bool) -> Vect n a -> Maybe Nat-findIndex = findIndex' 0-  where-    findIndex' : Nat -> (a -> Bool) -> Vect n a -> Maybe Nat-    findIndex' cnt p []      = Nothing-    findIndex' cnt p (x::xs) with (p x)-      | True  = Just cnt-      | False = findIndex' (S cnt) p xs+findIndex : (a -> Bool) -> Vect n a -> Maybe (Fin n)+findIndex p []        = Nothing+findIndex p (x :: xs) with (p x)+  | True  = Just 0+  | False = map FS (findIndex p xs)  ||| Find the indices of all elements that satisfy some test total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)@@ -394,10 +391,10 @@        else         (_ ** tail) -elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe Nat+elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe (Fin m) elemIndexBy p e = findIndex $ p e -elemIndex : Eq a => a -> Vect m a -> Maybe Nat+elemIndex : Eq a => a -> Vect m a -> Maybe (Fin m) elemIndex = elemIndexBy (==)  total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat)@@ -451,7 +448,7 @@ ||| A tuple where the first element is a Vect of the n first elements and ||| the second element is a Vect of the remaining elements of the original Vect ||| It is equivalent to (take n xs, drop n xs)-||| @ m   the index to split at+||| @ n   the index to split at ||| @ xs  the Vect to split in two splitAt : (n : Nat) -> (xs : Vect (n + m) a) -> (Vect n a, Vect m a) splitAt n xs = (take n xs, drop n xs)
libs/base/Language/Reflection/Utils.idr view
@@ -61,19 +61,47 @@ binderTy (PVar t)      = t binderTy (PVTy t)      = t -instance Show TTName where-  show (UN str)   = "(UN " ++ str ++ ")"-  show (NS n ns)  = "(NS " ++ show n ++ " " ++ show ns ++ ")"-  show (MN i str) = "(MN " ++ show i ++ " " ++ show str ++ ")"-  show NErased    = "NErased"+mutual+  instance Show SpecialName where+    show (WhereN i n1 n2) = "(WhereN " ++ show i ++ " " +++                            show n1 ++ " " ++ show n2 ++ ")"+    show (WithN i n) = "(WithN " ++ show i ++ " " ++ show n ++ ")"+    show (InstanceN i ss) = "(InstanceN " ++ show i ++ " " ++ show ss ++ ")"+    show (ParentN n s) = "(ParentN " ++ show n ++ " " ++ show s ++ ")"+    show (MethodN n) = "(MethodN " ++ show n ++ ")"+    show (CaseN n) = "(CaseN " ++ show n ++ ")"+    show (ElimN n) = "(ElimN " ++ show n ++ ")"+    show (InstanceCtorN n) = "(InstanceCtorN " ++ show n ++ ")"+    show (MetaN parent meta) = "(MetaN " ++ show parent ++ " " ++ show meta ++ ")" -instance Eq TTName where-  (UN str1)  == (UN str2)     = str1 == str2-  (NS n ns)  == (NS n' ns')   = n == n' && ns == ns'-  (MN i str) == (MN i' str')  = i == i' && str == str'-  NErased    == NErased       = True-  x          == y             = False+  instance Show TTName where+    show (UN str)   = "(UN " ++ str ++ ")"+    show (NS n ns)  = "(NS " ++ show n ++ " " ++ show ns ++ ")"+    show (MN i str) = "(MN " ++ show i ++ " " ++ show str ++ ")"+    show (SN sn)    = "(SN " ++ assert_total (show sn) ++ ")"+    show NErased    = "NErased" +mutual+  instance Eq TTName where+    (UN str1)  == (UN str2)     = str1 == str2+    (NS n ns)  == (NS n' ns')   = n == n' && ns == ns'+    (MN i str) == (MN i' str')  = i == i' && str == str'+    NErased    == NErased       = True+    (SN sn)    == (SN sn')      = assert_total $ sn == sn'+    x          == y             = False++  instance Eq SpecialName where+    (WhereN i n1 n2)    == (WhereN i' n1' n2')   = i == i' && n1 == n1' && n2 == n2'+    (WithN i n)         == (WithN i' n')         = i == i' && n == n'+    (InstanceN i ss)    == (InstanceN i' ss')    = i == i' && ss == ss'+    (ParentN n s)       == (ParentN n' s')       = n == n' && s == s'+    (MethodN n)         == (MethodN n')          = n == n'+    (CaseN n)           == (CaseN n')            = n == n'+    (ElimN n)           == (ElimN n')            = n == n'+    (InstanceCtorN n)   == (InstanceCtorN n')    = n == n'+    (MetaN parent meta) == (MetaN parent' meta') = parent == parent' && meta == meta'+    _                   == _                     = False+ instance Show TTUExp where   show (UVar i) = "(UVar " ++ show i ++ ")"   show (UVal i) = "(UVal " ++ show i ++ ")"@@ -93,15 +121,8 @@   show (B16 b)    = "(B16 ...)"   show (B32 b)    = "(B32 ...)"   show (B64 b)    = "(B64 ...)"-  show (B8V xs)   = "(B8V ...)"-  show (B16V xs) = "(B16V ...)"-  show (B32V xs) = "(B32V ...)"-  show (B64V xs) = "(B64V ...)"   show (AType x) = "(AType ...)"   show StrType = "StrType"-  show PtrType = "PtrType"-  show ManagedPtrType = "ManagedPtrType"-  show BufferType = "BufferType"   show VoidType = "VoidType"   show Forgot = "Forgot" @@ -117,7 +138,6 @@   ITNative    == ITNative    = True   ITBig       == ITBig       = True   ITChar      == ITChar      = True-  (ITVec x i) == (ITVec y j) = x == y && i == j   _           == _           = False  instance Eq ArithTy where@@ -135,15 +155,8 @@   (B16 x)        == (B16 y)         = x == y   (B32 x)        == (B32 y)         = x == y   (B64 x)        == (B64 y)         = x == y-  (B8V xs)       == (B8V ys)        = False -- TODO-  (B16V xs)      == (B16V ys)       = False -- TODO-  (B32V xs)      == (B32V ys)       = False -- TODO-  (B64V xs)      == (B64V ys)       = False -- TODO   (AType x)      == (AType y)       = x == y   StrType        == StrType         = True-  PtrType        == PtrType         = True-  ManagedPtrType == ManagedPtrType  = True-  BufferType     == BufferType      = True   VoidType       == VoidType        = True   Forgot         == Forgot          = True   _              == _               = False@@ -284,3 +297,12 @@   show (ProviderError x) = "ProviderError \"" ++ show x ++ "\""   show (LoadingFailed x err) = "LoadingFailed " ++ show x ++ " (" ++ show err ++ ")" +-------------------------+-- Idiom brackets for Raw+-------------------------++(<*>) : Raw -> Raw -> Raw+(<*>) = RApp++pure : Raw -> Raw+pure = id
libs/contrib/Classes/Verified.idr view
@@ -1,6 +1,8 @@ module Classes.Verified  import Control.Algebra+import Control.Algebra.Lattice+import Control.Algebra.VectorSpace  -- Due to these being basically unused and difficult to implement, -- they're in contrib for a bit. Once a design is found that lets them@@ -78,6 +80,11 @@   total ringWithUnityIsUnityL : (l : a) -> l <.> unity = l   total ringWithUnityIsUnityR : (r : a) -> unity <.> r = r +--class (VerifiedRingWithUnity a, Field a) => VerifiedField a where+--  total fieldInverseIsInverseL : (l : a) -> (notId : Not (l = neutral)) -> l <.> (inverseM l notId) = unity+--  total fieldInverseIsInverseR : (r : a) -> (notId : Not (r = neutral)) -> (inverseM r notId) <.> r = unity++ class JoinSemilattice a => VerifiedJoinSemilattice a where   total joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r   total joinSemilatticeJoinIsCommutative : (l, r : a)    -> join l r = join r l@@ -100,15 +107,11 @@  class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { } -class (VerifiedRing a, Field a) => VerifiedField a where-  total fieldInverseIsInverseL : (l : a) -> l <.> inverseM l = unity-  total fieldInverseIsInverseR : (r : a) -> inverseM r <.> r = unity --- class (VerifiedRingWithUnity a, VerifiedAbelianGroup b, Module a b) => VerifiedModule a b where---   total moduleScalarMultiplyComposition : (x,y : a) -> (v : b) -> x <#> (y <#> v) = (x <.> y) <#> v---   total moduleScalarUnityIsUnity : (v : b) -> unity <#> v = v---   total moduleScalarMultDistributiveWRTVectorAddition : (s : a) -> (v, w : b) -> s <#> (v <+> w) = (s <#> v) <+> (s <#> w)---   total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v)---- class (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}+--class (VerifiedRingWithUnity a, VerifiedAbelianGroup b, Module a b) => VerifiedModule a b where+--  total moduleScalarMultiplyComposition : (x,y : a) -> (v : b) -> x <#> (y <#> v) = (x <.> y) <#> v+--  total moduleScalarUnityIsUnity : (v : b) -> unity {a} <#> v = v+--  total moduleScalarMultDistributiveWRTVectorAddition : (s : a) -> (v, w : b) -> s <#> (v <+> w) = (s <#> v) <+> (s <#> w)+--  total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v) +--class (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}
libs/contrib/Control/Algebra.idr view
@@ -1,12 +1,9 @@ module Control.Algebra -import Data.Heap---- XXX: change? infixl 6 <->-infixl 6 <.>-infixl 5 <#>+infixl 7 <.> + ||| Sets equipped with a single binary operation that is associative, along with ||| a neutral element for that binary operation and inverses for all elements. ||| Must satisfy the following laws:@@ -40,7 +37,6 @@ |||     forall a,     inverse a <+> a == neutral class Group a => AbelianGroup a where { } - ||| Sets equipped with two binary operations, one associative and commutative ||| supplied with a neutral element, and the other associative, with ||| distributivity laws relating the two operations.  Must satisfy the following@@ -64,7 +60,6 @@ class AbelianGroup a => Ring a where   (<.>) : a -> a -> a - ||| Sets equipped with two binary operations, one associative and commutative ||| supplied with a neutral element, and the other associative supplied with a ||| neutral element, with distributivity laws relating the two operations.  Must@@ -91,137 +86,10 @@ class Ring a => RingWithUnity a where   unity : a --||| Sets equipped with a binary operation that is commutative, associative and-||| idempotent.  Must satisfy the following laws:-|||-||| + Associativity of join:-|||     forall a b c, join a (join b c) == join (join a b) c-||| + Commutativity of join:-|||     forall a b,   join a b          == join b a-||| + Idempotency of join:-|||     forall a,     join a a          == a-|||-||| Join semilattices capture the notion of sets with a "least upper bound".-class JoinSemilattice a where-  join : a -> a -> a--instance JoinSemilattice Nat where-  join = maximum--instance Ord a => JoinSemilattice (MaxiphobicHeap a) where-  join = merge--||| Sets equipped with a binary operation that is commutative, associative and-||| idempotent.  Must satisfy the following laws:-|||-||| + Associativity of meet:-|||     forall a b c, meet a (meet b c) == meet (meet a b) c-||| + Commutativity of meet:-|||     forall a b,   meet a b          == meet b a-||| + Idempotency of meet:-|||     forall a,     meet a a          == a-|||-||| Meet semilattices capture the notion of sets with a "greatest lower bound".-class MeetSemilattice a where-  meet : a -> a -> a--instance MeetSemilattice Nat where-  meet = minimum---||| Sets equipped with a binary operation that is commutative, associative and-||| idempotent and supplied with a unitary element.  Must satisfy the following-||| laws:-|||-||| + Associativity of join:-|||     forall a b c, join a (join b c) == join (join a b) c-||| + Commutativity of join:-|||     forall a b,   join a b          == join b a-||| + Idempotency of join:-|||     forall a,     join a a          == a-||| + Bottom (Unitary Element):-|||     forall a,     join a bottom     == a-|||-|||  Join semilattices capture the notion of sets with a "least upper bound"-|||  equipped with a "bottom" element.-class JoinSemilattice a => BoundedJoinSemilattice a where-  bottom  : a---instance BoundedJoinSemilattice Nat where-  bottom = Z---||| Sets equipped with a binary operation that is commutative, associative and-||| idempotent and supplied with a unitary element.  Must satisfy the following-||| laws:-|||-||| + Associativity of meet:-|||     forall a b c, meet a (meet b c) == meet (meet a b) c-||| + Commutativity of meet:-|||     forall a b,   meet a b          == meet b a-||| + Idempotency of meet:-|||     forall a,     meet a a          == a-||| +  Top (Unitary Element):-|||     forall a,     meet a top        == a-|||-||| Meet semilattices capture the notion of sets with a "greatest lower bound"-||| equipped with a "top" element.-class MeetSemilattice a => BoundedMeetSemilattice a where-  top : a----||| Sets equipped with two binary operations that are both commutative,-||| associative and idempotent, along with absorbtion laws for relating the two-||| binary operations.  Must satisfy the following:-|||-||| + Associativity of meet and join:-|||     forall a b c, meet a (meet b c) == meet (meet a b) c-|||     forall a b c, join a (join b c) == join (join a b) c-||| + Commutativity of meet and join:-|||     forall a b,   meet a b          == meet b a-|||     forall a b,   join a b          == join b a-||| + Idempotency of meet and join:-|||     forall a,     meet a a          == a-|||     forall a,     join a a          == a-||| + Absorbtion laws for meet and join:-|||     forall a b,   meet a (join a b) == a-|||     forall a b,   join a (meet a b) == a-class (JoinSemilattice a, MeetSemilattice a) => Lattice a where { }---instance Lattice Nat where { }--||| Sets equipped with two binary operations that are both commutative,-||| associative and idempotent and supplied with neutral elements, along with-||| absorbtion laws for relating the two binary operations.  Must satisfy the-||| following:-|||-||| + Associativity of meet and join:-|||     forall a b c, meet a (meet b c) == meet (meet a b) c-|||     forall a b c, join a (join b c) == join (join a b) c-||| +  Commutativity of meet and join:-|||     forall a b,   meet a b          == meet b a-|||     forall a b,   join a b          == join b a-||| + Idempotency of meet and join:-|||     forall a,     meet a a          == a-|||     forall a,     join a a          == a-||| + Absorbtion laws for meet and join:-|||     forall a b,   meet a (join a b) == a-|||     forall a b,   join a (meet a b) == a-||| + Neutral for meet and join:-|||     forall a,     meet a top        == top-|||     forall a,     join a bottom     == bottom-class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }-----   Fields.-||| Sets equipped with two binary operations, both associative and commutative-||| supplied with a neutral element, with-||| distributivity laws relating the two operations.  Must satisfy the following-||| laws:+||| Sets equipped with two binary operations – both associative, commutative and+||| possessing a neutral element – and distributivity laws relating the two+||| operations. All elements except the additive identity must have a+||| multiplicative inverse. Must satisfy the following laws: ||| ||| + Associativity of `<+>`: |||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c@@ -238,34 +106,24 @@ ||| + Unity for `<.>`: |||     forall a,     a <.> unity     == a |||     forall a,     unity <.> a     == a-||| + InverseM of `<.>`:-|||     forall a,     a <.> inverseM a == unity-|||     forall a,     inverseM a <.> a == unity+||| + InverseM of `<.>`, except for neutral+|||     forall a /= neutral,  a <.> inverseM a == unity+|||     forall a /= neutral,  inverseM a <.> a == unity ||| + Distributivity of `<.>` and `<->`: |||     forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c) |||     forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c) class RingWithUnity a => Field a where-  inverseM : a -> a-+  inverseM : (x : a) -> Not (x = neutral) -> a -||| A module over a ring is an additive abelian group of 'vectors' endowed with a-||| scale operation multiplying vectors by ring elements, and distributivity laws-||| relating the scale operation to both ring addition and module addition.-||| Must satisfy the following laws:-|||-||| + Compatibility of scalar multiplication with ring multiplication:-|||     forall a b v,  a <#> (b <#> v) = (a <.> b) <#> v-||| + Ring unity is the identity element of scalar multiplication:-|||     forall v,      unity <#> v = v-||| + Distributivity of `<#>` and `<+>`:-|||     forall a v w,  a <#> (v <+> w) == (a <#> v) <+> (a <#> w)-|||     forall a b v,  (a <+> b) <#> v == (a <#> v) <+> (b <#> v)-class (RingWithUnity a, AbelianGroup b) => Module a b where-  (<#>) : a -> b -> b+sum : (Foldable t, Monoid a) => t a -> a+sum = foldr (<+>) neutral +product : (Foldable t, RingWithUnity a) => t a -> a+product = foldr (<.>) unity -||| A vector space is a module over a ring that is also a field-class (Field a, Module a b) => VectorSpace a b where {}+power : RingWithUnity a => a -> Nat -> a+power _ Z     = unity+power x (S n) = x <.> (Algebra.power x n)   -- XXX todo:
+ libs/contrib/Control/Algebra/Lattice.idr view
@@ -0,0 +1,123 @@+module Control.Algebra.Lattice++import Control.Algebra+import Data.Heap+++||| Sets equipped with a binary operation that is commutative, associative and+||| idempotent.  Must satisfy the following laws:+|||+||| + Associativity of join:+|||     forall a b c, join a (join b c) == join (join a b) c+||| + Commutativity of join:+|||     forall a b,   join a b          == join b a+||| + Idempotency of join:+|||     forall a,     join a a          == a+|||+||| Join semilattices capture the notion of sets with a "least upper bound".+class JoinSemilattice a where+  join : a -> a -> a++instance JoinSemilattice Nat where+  join = maximum++instance Ord a => JoinSemilattice (MaxiphobicHeap a) where+  join = merge++||| Sets equipped with a binary operation that is commutative, associative and+||| idempotent.  Must satisfy the following laws:+|||+||| + Associativity of meet:+|||     forall a b c, meet a (meet b c) == meet (meet a b) c+||| + Commutativity of meet:+|||     forall a b,   meet a b          == meet b a+||| + Idempotency of meet:+|||     forall a,     meet a a          == a+|||+||| Meet semilattices capture the notion of sets with a "greatest lower bound".+class MeetSemilattice a where+  meet : a -> a -> a++instance MeetSemilattice Nat where+  meet = minimum++||| Sets equipped with a binary operation that is commutative, associative and+||| idempotent and supplied with a unitary element.  Must satisfy the following+||| laws:+|||+||| + Associativity of join:+|||     forall a b c, join a (join b c) == join (join a b) c+||| + Commutativity of join:+|||     forall a b,   join a b          == join b a+||| + Idempotency of join:+|||     forall a,     join a a          == a+||| + Bottom (Unitary Element):+|||     forall a,     join a bottom     == a+|||+|||  Join semilattices capture the notion of sets with a "least upper bound"+|||  equipped with a "bottom" element.+class JoinSemilattice a => BoundedJoinSemilattice a where+  bottom  : a++instance BoundedJoinSemilattice Nat where+  bottom = Z++||| Sets equipped with a binary operation that is commutative, associative and+||| idempotent and supplied with a unitary element.  Must satisfy the following+||| laws:+|||+||| + Associativity of meet:+|||     forall a b c, meet a (meet b c) == meet (meet a b) c+||| + Commutativity of meet:+|||     forall a b,   meet a b          == meet b a+||| + Idempotency of meet:+|||     forall a,     meet a a          == a+||| +  Top (Unitary Element):+|||     forall a,     meet a top        == a+|||+||| Meet semilattices capture the notion of sets with a "greatest lower bound"+||| equipped with a "top" element.+class MeetSemilattice a => BoundedMeetSemilattice a where+  top : a++||| Sets equipped with two binary operations that are both commutative,+||| associative and idempotent, along with absorbtion laws for relating the two+||| binary operations.  Must satisfy the following:+|||+||| + Associativity of meet and join:+|||     forall a b c, meet a (meet b c) == meet (meet a b) c+|||     forall a b c, join a (join b c) == join (join a b) c+||| + Commutativity of meet and join:+|||     forall a b,   meet a b          == meet b a+|||     forall a b,   join a b          == join b a+||| + Idempotency of meet and join:+|||     forall a,     meet a a          == a+|||     forall a,     join a a          == a+||| + Absorbtion laws for meet and join:+|||     forall a b,   meet a (join a b) == a+|||     forall a b,   join a (meet a b) == a+class (JoinSemilattice a, MeetSemilattice a) => Lattice a where { }++instance Lattice Nat where { }++||| Sets equipped with two binary operations that are both commutative,+||| associative and idempotent and supplied with neutral elements, along with+||| absorbtion laws for relating the two binary operations.  Must satisfy the+||| following:+|||+||| + Associativity of meet and join:+|||     forall a b c, meet a (meet b c) == meet (meet a b) c+|||     forall a b c, join a (join b c) == join (join a b) c+||| +  Commutativity of meet and join:+|||     forall a b,   meet a b          == meet b a+|||     forall a b,   join a b          == join b a+||| + Idempotency of meet and join:+|||     forall a,     meet a a          == a+|||     forall a,     join a a          == a+||| + Absorbtion laws for meet and join:+|||     forall a b,   meet a (join a b) == a+|||     forall a b,   join a (meet a b) == a+||| + Neutral for meet and join:+|||     forall a,     meet a top        == top+|||     forall a,     join a bottom     == bottom+class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }
+ libs/contrib/Control/Algebra/NumericInstances.idr view
@@ -0,0 +1,104 @@+module Control.Algebra.NumericInstances++import Control.Algebra+import Data.Complex+import Data.ZZ+++instance Semigroup Integer where+  (<+>) = (+)++instance Monoid Integer where+  neutral = 0++instance Group Integer where+  inverse = (* -1)++instance AbelianGroup Integer++instance Ring Integer where+  (<.>) = (*)++instance RingWithUnity Integer where+  unity = 1+++instance Semigroup Int where+  (<+>) = (+)++instance Monoid Int where+  neutral = 0++instance Group Int where+  inverse = (* -1)++instance AbelianGroup Int++instance Ring Int where+  (<.>) = (*)++instance RingWithUnity Int where+  unity = 1+++instance Semigroup Float where+  (<+>) = (+)++instance Monoid Float where+  neutral = 0++instance Group Float where+  inverse = (* -1)++instance AbelianGroup Float++instance Ring Float where+  (<.>) = (*)++instance RingWithUnity Float where+  unity = 1++instance Field Float where+  inverseM f _ = 1 / f+++instance Semigroup Nat where+  (<+>) = (+)++instance Monoid Nat where+  neutral = 0++instance Semigroup ZZ where+  (<+>) = (+)++instance Monoid ZZ where+  neutral = 0++instance Group ZZ where+  inverse = (* -1)++instance AbelianGroup ZZ++instance Ring ZZ where+  (<.>) = (*)++instance RingWithUnity ZZ where+  unity = 1+++instance Semigroup a => Semigroup (Complex a) where+  (<+>) (a :+ b) (c :+ d) = (a <+> c) :+ (b <+> d)++instance Monoid a => Monoid (Complex a) where+  neutral = (neutral :+ neutral)++instance Group a => Group (Complex a) where+  inverse (r :+ i) = (inverse r :+ inverse i)++instance Ring a => AbelianGroup (Complex a) where {}++instance Ring a => Ring (Complex a) where+  (<.>) (a :+ b) (c :+ d) = (a <.> c <-> b <.> d) :+ (a <.> d <+> b <.> c)++instance RingWithUnity a => RingWithUnity (Complex a) where+  unity = (unity :+ neutral)
+ libs/contrib/Control/Algebra/VectorSpace.idr view
@@ -0,0 +1,30 @@+module Control.Algebra.VectorSpace++import Control.Algebra++infixl 5 <#>+infixr 2 <||>+++||| A module over a ring is an additive abelian group of 'vectors' endowed with a+||| scale operation multiplying vectors by ring elements, and distributivity laws+||| relating the scale operation to both ring addition and module addition.+||| Must satisfy the following laws:+|||+||| + Compatibility of scalar multiplication with ring multiplication:+|||     forall a b v,  a <#> (b <#> v) = (a <.> b) <#> v+||| + Ring unity is the identity element of scalar multiplication:+|||     forall v,      unity <#> v = v+||| + Distributivity of `<#>` and `<+>`:+|||     forall a v w,  a <#> (v <+> w) == (a <#> v) <+> (a <#> w)+|||     forall a b v,  (a <+> b) <#> v == (a <#> v) <+> (b <#> v)+class (RingWithUnity a, AbelianGroup b) => Module a b where+  (<#>) : a -> b -> b++||| A vector space is a module over a ring that is also a field+class (Field a, Module a b) => VectorSpace a b where {}++||| An inner product space is a module – or vector space – over a ring, with a binary function+||| associating a ring value to each pair of vectors.+class Module a b => InnerProductSpace a b where+  (<||>) : b -> b -> a
+ libs/contrib/Control/Partial.idr view
@@ -0,0 +1,14 @@+||| Control structures that are fundamentally partial+module Control.Partial+++||| Repeatedly apply `f` to `v` until `p` is `True`.+|||+||| @ p the predicate to wait for+||| @ f the function to repeatedly apply+||| @ v the starting value+partial+until : (p : a -> Bool) -> (f : a -> a) -> (v : a) -> a+until p f v with (p v)+  | False = until p f (f v)+  | True = v
+ libs/contrib/Control/WellFounded.idr view
@@ -0,0 +1,83 @@+||| Well-founded recursion.+|||+||| This is to let us implement some functions that don't have trivial+||| recursion patterns over datatypes, but instead are using some+||| other metric of size.+module Control.WellFounded++%default total+++||| Accessibility: some element `x` is accessible if all `y` such that+||| `rel y x` are themselves accessible.+|||+||| @ a the type of elements+||| @ rel a relation on a+||| @ x the acessible element+data Accessible : (rel : a -> a -> Type) -> (x : a) -> Type where+  ||| Accessibility+  |||+  ||| @ x the accessible element+  ||| @ acc' a demonstration that all smaller elements are also accessible+  Access : (acc' : (y : a) -> rel y x -> Accessible rel y) ->+           Accessible rel x++||| A relation `rel` on `a` is well-founded if all elements of `a` are+||| acessible.+|||+||| @ rel the well-founded relation+class WellFounded (rel : a -> a -> Type) where+  wellFounded : (x : _) -> Accessible rel x+++||| A recursor over accessibility.+|||+||| This allows us to recurse over the subset of some type that is+||| accessible according to some relation.+|||+||| @ rel the well-founded relation+||| @ step how to take steps on reducing arguments+||| @ z the starting point+accRec : {rel : a -> a -> Type} ->+         (step : (x : a) -> ((y : a) -> rel y x -> b) -> b) ->+         (z : a) -> Accessible rel z -> b+accRec step z (Access f) =+  step z $ \y, lt => accRec step y (f y lt)++||| An induction principle for accessibility.+|||+||| This allows us to recurse over the subset of some type that is+||| accessible according to some relation, producing a dependent type+||| as a result.+|||+||| @ rel the well-founded relation+||| @ step how to take steps on reducing arguments+||| @ z the starting point+accInd : {rel : a -> a -> Type} -> {P : a -> Type} ->+         (step : (x : a) -> ((y : a) -> rel y x -> P y) -> P x) ->+         (z : a) -> Accessible rel z -> P z+accInd step z (Access f) =+  step z $ \y, lt => accInd step y (f y lt)+++||| Use well-foundedness of a relation to write terminating operations.+|||+||| @ rel a well-founded relation+wfRec : WellFounded rel =>+        (step : (x : a) -> ((y : a) -> rel y x -> b) -> b) ->+        a -> b+wfRec {rel} step x = accRec step x (wellFounded {rel} x)+++||| Use well-foundedness of a relation to write proofs+|||+||| @ rel a well-founded relation+||| @ P the motive for the induction+||| @ step the induction step: take an element and its accessibility,+|||        and give back a demonstration of P for that element,+|||        potentially using accessibility+wfInd : WellFounded rel => {P : a -> Type} ->+        (step : (x : a) -> ((y : a) -> rel y x -> P y) -> P x) ->+        (x : a) -> P x+wfInd {rel} step x = accInd step x (wellFounded {rel} x)+
− libs/contrib/Data/Buffer.idr 
@@ -1,254 +0,0 @@-module Data.Buffer--import Data.Fin--%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
+ libs/contrib/Data/CoList.idr view
@@ -0,0 +1,54 @@+module Data.CoList++%access public+%default total++||| Idris will know that it always can produce a new element in finite time+codata CoList : Type -> Type where+  Nil : CoList a+  (::) : a -> CoList a -> CoList a++||| Append two CoLists+(++) : CoList a -> CoList a -> CoList a+(++) []      right = right+(++) (x::xs) right = x :: (xs ++ right)++instance Semigroup (CoList a) where+  (<+>) = (++)++instance Monoid (CoList a) where+  neutral = []++instance Functor CoList where+  map f []      = []+  map f (x::xs) = f x :: map f xs++instance Show a => Show (CoList a) where+  show xs = "[" ++ show' "" 20 xs ++ "]" where+    show' : String -> (n : Nat) -> (xs : CoList a) -> String+    show' acc Z _             = acc ++ "..."+    show' acc (S n) []        = acc+    show' acc (S n) [x]       = acc ++ show x+    show' acc (S n) (x :: xs) = show' (acc ++ (show x) ++ ", ") n xs++||| Take the first `n` elements of `xs`+|||+||| If there are not enough elements, return the whole coList.+||| @ n how many elements to take+||| @ xs the coList to take them from+takeCo : (n : Nat) -> (xs : CoList a) -> List a+takeCo Z _ = []+takeCo (S n) [] = []+takeCo (S n) (x::xs) = x :: takeCo n xs++||| The unfoldr builds a list from a seed value. In some cases, unfoldr can undo a foldr operation.+|||+||| ``` idris example+||| unfoldr (\b => if b == 0 then Nothing else Just (b, b-1)) 10+||| ```+|||+unfoldr : (a -> Maybe (a, a)) -> a -> CoList a+unfoldr f x =+  case f x of+    Just (y, new_x) => y :: (unfoldr f new_x)+    _               => []
libs/contrib/Data/Matrix.idr view
@@ -1,6 +1,8 @@ module Data.Matrix -import Control.Algebra+import        Control.Algebra+import        Control.Algebra.VectorSpace+import public Control.Algebra.NumericInstances  import Data.Complex import Data.ZZ@@ -40,8 +42,7 @@ instance RingWithUnity a => RingWithUnity (Vect n a) where   unity {n} = replicate n unity -instance Field a => Field (Vect n a) where-  inverseM = map inverseM+--instance Field a => Field (Vect n a) where  instance RingWithUnity a => Module a (Vect n a) where   (<#>) r v = map (r <.>) v@@ -147,104 +148,3 @@  -- TODO: Prove properties of matrix algebra for 'Verified' algebraic classes ---------------------------------------------------------------------------                    Numberic data types as rings--------------------------------------------------------------------------instance Semigroup Integer where-  (<+>) = (+)--instance Monoid Integer where-  neutral = 0--instance Group Integer where-  inverse = (* -1)--instance AbelianGroup Integer--instance Ring Integer where-  (<.>) = (*)--instance RingWithUnity Integer where-  unity = 1---instance Semigroup Int where-  (<+>) = (+)--instance Monoid Int where-  neutral = 0--instance Group Int where-  inverse = (* -1)--instance AbelianGroup Int--instance Ring Int where-  (<.>) = (*)--instance RingWithUnity Int where-  unity = 1---instance Semigroup Float where-  (<+>) = (+)--instance Monoid Float where-  neutral = 0--instance Group Float where-  inverse = (* -1)--instance AbelianGroup Float--instance Ring Float where-  (<.>) = (*)--instance RingWithUnity Float where-  unity = 1--instance Field Float where-  inverseM f = 1 / f---instance Semigroup Nat where-  (<+>) = (+)--instance Monoid Nat where-  neutral = 0--instance Semigroup ZZ where-  (<+>) = (+)--instance Monoid ZZ where-  neutral = 0--instance Group ZZ where-  inverse = (* -1)--instance AbelianGroup ZZ--instance Ring ZZ where-  (<.>) = (*)--instance RingWithUnity ZZ where-  unity = 1---instance Semigroup a => Semigroup (Complex a) where-  (<+>) (a :+ b) (c :+ d) = (a <+> c) :+ (b <+> d)--instance Monoid a => Monoid (Complex a) where-  neutral = (neutral :+ neutral)--instance Group a => Group (Complex a) where-  inverse (r :+ i) = (inverse r :+ inverse i)--instance Ring a => AbelianGroup (Complex a) where {}--instance Ring a => Ring (Complex a) where-  (<.>) (a :+ b) (c :+ d) = (a <.> c <-> b <.> d) :+ (a <.> d <+> b <.> c)--instance RingWithUnity a => RingWithUnity (Complex a) where-  unity = (unity :+ neutral)
+ libs/contrib/Data/Nat.idr view
@@ -0,0 +1,166 @@+||| Extra utilities for working with Nats+module Data.Nat++import Data.Fin+import Data.So++import Control.WellFounded++%default total+%access public++||| A strict less-than relation on `Nat`.+|||+||| @ n the smaller number+||| @ m the larger number+data LT' : (n,m : Nat) -> Type where+  ||| n < 1 + n+  LTSucc : LT' n (S n)+  ||| n < m implies that n < m + 1+  LTStep : LT' n m -> LT' n (S m)++%name LT' lt, lt'++||| Nothing is strictly less than zero+instance Uninhabited (LT' n 0) where+  uninhabited LTSucc impossible++||| Zero is less than any non-zero number.+LTZeroLeast : LT' Z (S n)+LTZeroLeast {n = Z}   = LTSucc+LTZeroLeast {n = S n} = LTStep LTZeroLeast++||| If n < m, then 1 + n < 1 + m+ltSuccSucc : LT' n m -> LT' (S n) (S m)+ltSuccSucc LTSucc      = LTSucc+ltSuccSucc (LTStep lt) = LTStep $ ltSuccSucc lt++||| If n + 1 < m, then n < m+lteToLt' : LTE (S n) m -> LT' n m+lteToLt' {n = Z}   (LTESucc x) = LTZeroLeast+lteToLt' {n = S k} (LTESucc x) = ltSuccSucc $ lteToLt' x++||| Convert from LT' to LTE+ltToLTE : LT' n m -> LTE (S n) m+ltToLTE LTSucc      = lteRefl+ltToLTE (LTStep lt) = lteSuccRight $ ltToLTE lt++||| Subtraction gives a result that is actually smaller.+minusLT' : (x,y : Nat) -> x - y `LT'` S x+minusLT' Z     y = LTSucc+minusLT' (S k) Z = LTSucc+minusLT' (S k) (S j) = LTStep (minusLT' k j)++||| Strict less-than is well-founded, with the cascade stopping at+||| zero (because there's nothing less than zero). This can't be done+||| for LTE, because that one doesn't stop at zero (because `LTE 0 0`+||| is inhabited).+instance WellFounded LT' where+  wellFounded x = Access (acc x)+    where+      ||| Show accessibility by induction on the structure of the LT' witness+      acc : (x, y : Nat) -> LT' y x -> Accessible LT' y+      -- Zero is vacuously accessible: there's nothing smaller to check+      acc Z     y lt = absurd lt+      -- If the element being accessed is one smaller, we're done+      acc (S y) y LTSucc = Access (acc y)+      -- If the element is more than one smaller, we need to go further+      acc (S k) y (LTStep smaller) = acc k y smaller++||| The result of division on natural numbers.+|||+||| @ dividend the dividend+||| @ divisor the divisor+data DivMod : (dividend, divisor : Nat) -> Type where+  ||| The result of division, with a quotient and a remainder.+  |||+  ||| @ dividend the dividend+  ||| @ divisor the divisor+  ||| @ quotient the quotient+  ||| @ remainder the remainder (bounded by the divisor)+  ||| @ ok the fact that this is, in fact, a result of division+  DivModRes : {dividend, divisor : Nat} ->+              (quotient : Nat) -> (remainder : Fin divisor) ->+              (ok : dividend = finToNat remainder + quotient * divisor) ->+              DivMod dividend divisor+++||| Any natural number can be a `Fin` where the bound is itself plus some difference.+private+toFin : (x : Nat) -> (diff : Nat) -> Fin (plus x (S diff))+toFin Z diff = FZ+toFin (S k) diff = FS $ toFin k diff++||| Converting to a `Fin` and back to `Nat` preserves the input. This is a correctness proof for `toFin`.+private+toFinAndBack : (x : Nat) -> (diff : Nat) -> finToNat (toFin x diff) = x+toFinAndBack Z diff = Refl+toFinAndBack (S k) diff = cong (toFinAndBack k diff)+++||| The accessibilty predicate used for division.+private+accPlusLT' : LT' (S j) (S (plus k (S j)))+accPlusLT' {j = Z}   {k = Z}   = LTSucc+accPlusLT' {j = Z}   {k = S k} = LTStep (accPlusLT' {j = Z} {k = k})+accPlusLT' {j = S j} {k = k}   = rewrite sym $ plusSuccRightSucc k (S j) in+                                 ltSuccSucc accPlusLT'+++||| Division and modulus on `Nat`, inspired by the definition in the+||| Agda standard library.+|||+||| This uses well-founded recursion on `LT'`.+|||+||| @ dividend the dividend+||| @ divisor the divisor+||| @ nonzero division by zero is nonsense+total -- yay!+divMod : (dividend, divisor : Nat) ->+         {auto nonzero : So (not (decAsBool (decEq divisor Z)))} ->+         DivMod dividend divisor+divMod _     Z     {nonzero} = absurd nonzero+divMod Z     (S k)           = DivModRes 0 FZ Refl+divMod (S j) (S k) {nonzero} = wfInd {P=P} stepDiv (S j) (S k) nonzero+  where+    ||| The goal passed to the accessibility eliminator.+    |||+    ||| This is responsible for generating the goal in the+    ||| well-founded fixed point.+    |||+    ||| @ dividend the dividend to recurse over+    P : (dividend : Nat) -> Type+    P dividend = (divisor : Nat) -> (nonzero : So (not (decAsBool (decEq divisor Z)))) -> DivMod dividend divisor+++    ||| Well-founded recursion needs a recursion operator.+    |||+    ||| @ dividend the dividend we are recursing over+    ||| @ rec the recursive call provided by the well-founded induction operator+    stepDiv : (dividend : Nat) -> (rec : (d' : Nat) -> LT' d' dividend -> P d') -> P dividend+    -- We need not consider division by zero+    stepDiv dividend rec   Z     nonzero = absurd nonzero+    -- Dividing zero by anyting else gives 0, with 0 remainder+    stepDiv Z rec (S k) nonzero = DivModRes 0 0 Refl+    -- To divide two non-zero values, we must know which is larger+    stepDiv (S j) rec (S k) nonzero with (cmp j k)+      -- n / n = 1 remainder 0+      stepDiv (S j)                 rec (S j)                 nonzero | CmpEQ      =+        DivModRes 1 0 (sym $ cong (plusZeroRightNeutral j))+      -- if n < m, then m = n + r, and the quotient is 0 with remainder r+      stepDiv (S j)                 rec (S (plus j (S diff))) nonzero | CmpLT diff =+        DivModRes 0 (toFin (S j) diff) $+          rewrite toFinAndBack j diff+          in sym $ cong (plusZeroRightNeutral j)+      -- if n > m, then n = m + d, and the quotient is 1 + ((n - m) / m) with the same remainder+      stepDiv (S (plus k (S diff))) rec (S k)                 nonzero | CmpGT diff =+        let res = rec (S diff) accPlusLT' (S k) Oh+        in case res of+             DivModRes quotient remainder ok =>+               DivModRes (S quotient) remainder $+                 rewrite plusAssociative (finToNat remainder) (S k) (mult quotient (S k)) in+                 rewrite plusCommutative (finToNat remainder) (S k) in+                 rewrite sym $ plusAssociative (S k) (finToNat remainder) (mult quotient (S k)) in+                 rewrite ok in Refl++
libs/contrib/Data/SortedMap.idr view
@@ -2,72 +2,73 @@  -- TODO: write merge and split -data Tree : Nat -> Type -> Type -> Type where-  Leaf : k -> v -> Tree Z k v-  Branch2 : Tree n k v -> k -> Tree n k v -> Tree (S n) k v-  Branch3 : Tree n k v -> k -> Tree n k v -> k -> Tree n k v -> Tree (S n) k v+private+data Tree : Nat -> (k : Type) -> Type -> Ord k -> Type where+  Leaf : k -> v -> Tree Z k v o+  Branch2 : Tree n k v o -> k -> Tree n k v o -> Tree (S n) k v o+  Branch3 : Tree n k v o -> k -> Tree n k v o -> k -> Tree n k v o -> Tree (S n) k v o  branch4 :-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v ->-  Tree (S (S n)) k v+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o ->+  Tree (S (S n)) k v o branch4 a b c d e f g =   Branch2 (Branch2 a b c) d (Branch2 e f g)  branch5 :-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v ->-  Tree (S (S n)) k v+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o ->+  Tree (S (S n)) k v o branch5 a b c d e f g h i =   Branch2 (Branch2 a b c) d (Branch3 e f g h i)  branch6 :-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v ->-  Tree (S (S n)) k v+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o ->+  Tree (S (S n)) k v o branch6 a b c d e f g h i j k =   Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)  branch7 :-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v -> k ->-  Tree n k v ->-  Tree (S (S n)) k v+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o -> k ->+  Tree n k v o ->+  Tree (S (S n)) k v o branch7 a b c d e f g h i j k l m =   Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m) -merge1 : Tree n k v -> k -> Tree (S n) k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v+merge1 : Tree n k v o -> k -> Tree (S n) k v o -> k -> Tree (S n) k v o -> Tree (S (S n)) k v o merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m -merge2 : Tree (S n) k v -> k -> Tree n k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v+merge2 : Tree (S n) k v o -> k -> Tree n k v o -> k -> Tree (S n) k v o -> Tree (S (S n)) k v o merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m -merge3 : Tree (S n) k v -> k -> Tree (S n) k v -> k -> Tree n k v -> Tree (S (S n)) k v+merge3 : Tree (S n) k v o -> k -> Tree (S n) k v o -> k -> Tree n k v o -> Tree (S (S n)) k v o merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m -treeLookup : Ord k => k -> Tree n k v -> Maybe v+treeLookup : k -> Tree n k v o -> Maybe v treeLookup k (Leaf k' v) =   if k == k' then     Just v@@ -86,7 +87,7 @@   else     treeLookup k t3 -treeInsert' : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree n k v, k, Tree n k v)+treeInsert' : k -> v -> Tree n k v o -> Either (Tree n k v o) (Tree n k v o, k, Tree n k v o) treeInsert' k v (Leaf k' v') =   case compare k k' of     LT => Right (Leaf k v, k, Leaf k' v')@@ -116,17 +117,17 @@         Left t3' => Left (Branch3 t1 k1 t2 k2 t3')         Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c) -treeInsert : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree (S n) k v)+treeInsert : k -> v -> Tree n k v o -> Either (Tree n k v o) (Tree (S n) k v o) treeInsert k v t =   case treeInsert' k v t of     Left t' => Left t'     Right (a, b, c) => Right (Branch2 a b c) -delType : Nat -> Type -> Type -> Type-delType Z k v = ()-delType (S n) k v = Tree n k v+delType : Nat -> (k : Type) -> Type -> Ord k -> Type+delType Z k v o = ()+delType (S n) k v o = Tree n k v o -treeDelete : Ord k => k -> Tree n k v -> Either (Tree n k v) (delType n k v)+treeDelete : k -> Tree n k v o -> Either (Tree n k v o) (delType n k v o) treeDelete k (Leaf k' v) =   if k == k' then     Right ()@@ -183,33 +184,38 @@       Left t3' => Left (Branch3 t1 k1 t2 k2 t3')       Right t3' => Left (merge3 t1 k1 t2 k2 t3') -treeToList : Tree n k v -> List (k, v)+treeToList : Tree n k v o -> List (k, v) treeToList = treeToList' (:: [])   where-    treeToList' : ((k, v) -> List (k, v)) -> Tree n k v -> List (k, v)+    treeToList' : ((k, v) -> List (k, v)) -> Tree n k v o -> List (k, v)     treeToList' cont (Leaf k v) = cont (k, v)     treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1     treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1 +abstract data SortedMap : Type -> Type -> Type where-  Empty : SortedMap k v-  M : (n:Nat) -> Tree n k v -> SortedMap k v+  Empty : Ord k => SortedMap k v+  M : (o : Ord k) => (n:Nat) -> Tree n k v o -> SortedMap k v -empty : SortedMap k v+public+empty : Ord k => SortedMap k v empty = Empty -lookup : Ord k => k -> SortedMap k v -> Maybe v+public+lookup : k -> SortedMap k v -> Maybe v lookup _ Empty = Nothing lookup k (M _ t) = treeLookup k t -insert : Ord k => k -> v -> SortedMap k v -> SortedMap k v+public+insert : k -> v -> SortedMap k v -> SortedMap k v insert k v Empty = M Z (Leaf k v) insert k v (M _ t) =   case treeInsert k v t of     Left t' => (M _ t')     Right t' => (M _ t') -delete : Ord k => k -> SortedMap k v -> SortedMap k v+public+delete : k -> SortedMap k v -> SortedMap k v delete _ Empty = Empty delete k (M Z t) =   case treeDelete k t of@@ -220,18 +226,23 @@     Left t' => (M _ t')     Right t' => (M _ t') +public fromList : Ord k => List (k, v) -> SortedMap k v fromList l = foldl (flip (uncurry insert)) empty l +public toList : SortedMap k v -> List (k, v) toList Empty = [] toList (M _ t) = treeToList t -instance Functor (Tree n k) where-  map f (Leaf k v) = Leaf k (f v)-  map f (Branch2 t1 k t2) = Branch2 (map f t1) k (map f t2)-  map f (Branch3 t1 k1 t2 k2 t3) = Branch3 (map f t1) k1 (map f t2) k2 (map f t3)+public+treeMap : (a -> b) -> Tree n k a o -> Tree n k b o+treeMap f (Leaf k v) = Leaf k (f v)+treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)+treeMap f (Branch3 t1 k1 t2 k2 t3) +    = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3)  instance Functor (SortedMap k) where   map _ Empty = Empty-  map f (M n t) = M _ (map f t)+  map f (M n t) = M _ (treeMap f t)+
libs/contrib/Data/SortedSet.idr view
@@ -4,23 +4,30 @@  -- TODO: add intersection, union, difference +abstract data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ()) -empty : SortedSet k+public+empty : Ord k => SortedSet k empty = SetWrapper Data.SortedMap.empty -insert : Ord k => k -> SortedSet k -> SortedSet k+public+insert : k -> SortedSet k -> SortedSet k insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m) -delete : Ord k => k -> SortedSet k -> SortedSet k+public+delete : k -> SortedSet k -> SortedSet k delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m) -contains : Ord k => k -> SortedSet k -> Bool+public+contains : k -> SortedSet k -> Bool contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m) +public fromList : Ord k => List k -> SortedSet k fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l)) +public toList : SortedSet k -> List k toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)
+ libs/contrib/Data/String.idr view
@@ -0,0 +1,31 @@+module Data.String++infixl 5 +>+infixr 5 <+++||| Adds a character to the end of the specified string.+|||+||| ```idris example+||| strSnoc "AB" 'C'+||| ```+||| ```idris example+||| strSnoc "" 'A'+||| ```+strSnoc : String -> Char -> String+strSnoc s c = s ++ (singleton c)++||| Alias of `strSnoc`+|||+||| ```idris example+||| "AB" +> 'C'+||| ```+(+>) : String -> Char -> String+(+>) = strSnoc++||| Alias of `strCons`+|||+||| ```idris example+||| 'A' <+ "AB"+||| ```+(<+) : Char -> String -> String+(<+) = strCons
libs/contrib/Network/Cgi.idr view
@@ -8,13 +8,14 @@ Vars : Type Vars = List (String, String) -record CGIInfo : Type where-       CGISt : (GET : Vars) ->-               (POST : Vars) ->-               (Cookies : Vars) ->-               (UserAgent : String) ->-               (Headers : String) ->-               (Output : String) -> CGIInfo+record CGIInfo where+  constructor CGISt+  GET : Vars+  POST : Vars+  Cookies : Vars+  UserAgent : String+  Headers : String+  Output : String  add_Headers : String -> CGIInfo -> CGIInfo add_Headers str st = record { Headers = Headers st ++ str } st@@ -108,7 +109,7 @@         | _      = Nothing  getContent : Int -> IO String-getContent x = getC (toNat x) "" where+getContent x = getC (cast x) "" where     getC : Nat -> String -> IO String     getC Z     acc = return $ reverse acc     getC (S k) acc = do x <- getChar
libs/contrib/Network/Socket.idr view
@@ -107,19 +107,17 @@ EAGAIN = 11  -- TODO: Expand to non-string payloads-record UDPRecvData : Type where-  MkUDPRecvData : -    (remote_addr : SocketAddress) ->-    (remote_port : Port) ->-    (recv_data : String) ->-    (data_len : Int) ->-    UDPRecvData+record UDPRecvData where+  constructor MkUDPRecvData+  remote_addr : SocketAddress+  remote_port : Port+  recv_data : String+  data_len : Int -record UDPAddrInfo : Type where-  MkUDPAddrInfo : -    (remote_addr : SocketAddress) ->-    (remote_port : Port) ->-    UDPAddrInfo+record UDPAddrInfo where+  constructor MkUDPAddrInfo+  remote_addr : SocketAddress+  remote_port : Port  ||| Frees a given pointer public@@ -138,12 +136,12 @@ sock_alloc bl = map BPtr $ foreign FFI_C "idrnet_malloc" (Int -> IO Ptr) bl  ||| The metadata about a socket-record Socket : Type where-  MkSocket : (descriptor : SocketDescriptor) ->-             (family : SocketFamily) ->-             (socketType : SocketType) ->-             (protocolNumber : ProtocolNumber) ->-             Socket+record Socket where+  constructor MkSocket+  descriptor : SocketDescriptor+  family : SocketFamily+  socketType : SocketType+  protocalNumber : ProtocolNumber  ||| Get the C error number getErrno : IO Int
libs/contrib/contrib.ipkg view
@@ -2,14 +2,20 @@  opts = "--nobasepkgs --total -i ../prelude -i ../base" modules = Control.Algebra,+          Control.Algebra.Lattice, Control.Algebra.VectorSpace,+          Control.Algebra.NumericInstances,           Control.Isomorphism.Primitives,+          Control.Partial,+          Control.WellFounded,           Classes.Verified,-          Data.Fun, Data.Rel, Data.Buffer,+          Data.Fun, Data.Rel,           Data.Hash, Data.Matrix,+          Data.Nat,           Data.ZZ, Data.Sign,           Data.BoundedList,           Data.Heap,           Data.SortedMap, Data.SortedSet,+          Data.CoList,            Decidable.Decidable, Decidable.Order,
libs/effects/Effect/Exception.idr view
@@ -5,7 +5,7 @@ import Control.IOExcept  data Exception : Type -> Effect where-     Raise : a -> { () } Exception a b+     Raise : a -> sig (Exception a) b  instance Handler (Exception a) Maybe where      handle _ (Raise e) k = Nothing@@ -26,16 +26,5 @@ EXCEPTION : Type -> EFFECT EXCEPTION t = MkEff () (Exception t) -raise : a -> { [EXCEPTION a ] } Eff b+raise : a -> Eff b [EXCEPTION a] raise err = call $ 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?
libs/effects/Effect/File.idr view
@@ -46,29 +46,29 @@   ||| @ m The file mode.   Open : (fname: String)          -> (m : Mode)-         -> {() ==> {res} if res-                             then OpenFile m-                             else ()} FileIO Bool+         -> sig FileIO Bool () (\res => case res of+                                             True => OpenFile m+                                             False => ())    ||| Close a file.   |||    ||| Closing a file moves the state from Open to closed.-  Close : {OpenFile m ==> ()} FileIO () +  Close : sig FileIO () (OpenFile m) ()     ||| Read a line from the file.   |||    ||| Only files that are open for reading can be read.-  ReadLine : {OpenFile Read}  FileIO String +  ReadLine : sig FileIO String (OpenFile Read)      ||| Write a string to a file.   |||    ||| Only file that are open for writing can be written to.-  WriteString : String -> {OpenFile Write} FileIO ()+  WriteString : String -> sig FileIO () (OpenFile Write)    ||| End of file?   |||    ||| Only files open for reading can be tested for EOF-  EOF : {OpenFile Read}  FileIO Bool+  EOF : sig FileIO Bool (OpenFile Read)  -- ------------------------------------------------------------ [ The Handlers ] @@ -117,31 +117,31 @@ ||| @ m The file mode. open : (fname : String)        -> (m : Mode)-       -> { [FILE_IO ()] ==> {result}-            [FILE_IO (if result-                        then OpenFile m-                        else ())] } Eff Bool+       -> Eff Bool [FILE_IO ()] +                   (\res => [FILE_IO (case res of+                                           True => OpenFile m+                                           False => ())]) open f m = call $ Open f m   ||| Close a file.-close : { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff ()+close : Eff () [FILE_IO (OpenFile m)] [FILE_IO ()] close = call $ Close  ||| Read a line from the file.-readLine : { [FILE_IO (OpenFile Read)] } Eff String +readLine : Eff String [FILE_IO (OpenFile Read)] readLine = call $ ReadLine  ||| Write a string to a file.-writeString : String -> { [FILE_IO (OpenFile Write)] } Eff ()+writeString : String -> Eff () [FILE_IO (OpenFile Write)] writeString str = call $ WriteString str  ||| Write a line to a file.-writeLine : String -> { [FILE_IO (OpenFile Write)] } Eff ()+writeLine : String -> Eff () [FILE_IO (OpenFile Write)] writeLine str = call $ WriteString (str ++ "\n")  ||| End of file?-eof : { [FILE_IO (OpenFile Read)] } Eff Bool +eof : Eff Bool [FILE_IO (OpenFile Read)] eof = call $ EOF  -- --------------------------------------------------------------------- [ EOF ]
libs/effects/Effect/Random.idr view
@@ -5,28 +5,27 @@ import Data.Fin  data Random : Effect where -     getRandom : { Integer } Random Integer -     setSeed   : Integer -> { Integer } Random () +     getRandom : sig Random Integer Integer+     setSeed   : Integer -> sig Random () Integer -using (m : Type -> Type)-  instance Handler Random m where-     handle seed getRandom k-              = let seed' = assert_total ((1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32)) in-                    k seed' seed'-     handle seed (setSeed n) k = k () n+instance Handler Random m where+  handle seed getRandom k+           = let seed' = assert_total ((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  ||| Generates a random Integer in a given range-rndInt : Integer -> Integer -> { [RND] } Eff Integer+rndInt : Integer -> Integer -> Eff Integer [RND] rndInt lower upper = do v <- call $ getRandom                         return ((v `prim__sremBigInt` (upper - lower)) + lower)  ||| Generate a random number in Fin (S `k`) |||  ||| Note that rndFin k takes values 0, 1, ..., k.-rndFin : (k : Nat) -> { [RND] } Eff (Fin (S k))+rndFin : (k : Nat) -> Eff (Fin (S k)) [RND] rndFin k = do let v = assert_total $ !(call getRandom) `prim__sremBigInt` (cast (S k))               return (toFin v)  where toFin : Integer -> Fin (S k) @@ -35,15 +34,15 @@                       Nothing => toFin (assert_smaller x (x - cast (S k)))  ||| Select a random element from a vector-rndSelect' : Vect (S k) a -> { [RND] } Eff a+rndSelect' : Vect (S k) a -> Eff a [RND] rndSelect' {k} xs = return (Vect.index !(rndFin k)  xs)  ||| Select a random element from a list, or Nothing if the list is empty-rndSelect : List a -> { [RND] } Eff (Maybe a)+rndSelect : List a -> Eff (Maybe a) [RND] rndSelect []      = return Nothing rndSelect (x::xs) = return (Just !(rndSelect' (x::(fromList xs))))  ||| Sets the random seed-srand : Integer -> { [RND] } Eff ()+srand : Integer -> Eff () [RND] srand n = call $ setSeed n
libs/effects/Effect/Select.idr view
@@ -3,7 +3,7 @@ import Effects  data Selection : Effect where-     Select : List a -> { () } Selection a +     Select : List a -> sig Selection a ()  instance Handler Selection Maybe where      handle _ (Select xs) k = tryAll xs where@@ -18,6 +18,6 @@ SELECT : EFFECT SELECT = MkEff () Selection -select : List a -> { [SELECT] } Eff a +select : List a -> Eff a [SELECT] select xs = call $ Select xs
libs/effects/Effect/State.idr view
@@ -5,8 +5,8 @@ %access public  data State : Effect where-  Get :      { a }       State a-  Put : b -> { a ==> b } State () +  Get :      sig State a  a+  Put : b -> sig State () a b  -- using (m : Type -> Type) instance Handler State m where@@ -16,22 +16,22 @@ STATE : Type -> EFFECT STATE t = MkEff t State -get : { [STATE x] } Eff x+get : Eff x [STATE x] get = call $ Get -put : x -> { [STATE x] } Eff () +put : x -> Eff () [STATE x] put val = call $ Put val -putM : y -> { [STATE x] ==> [STATE y] } Eff () +putM : y -> Eff () [STATE x] [STATE y] putM val = call $ Put val -update : (x -> x) -> { [STATE x] } Eff () +update : (x -> x) -> Eff () [STATE x] update f = put (f !get) -updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff () +updateM : (x -> y) -> Eff () [STATE x] [STATE y] updateM f = putM (f !get) -locally : x -> ({ [STATE x] } Eff t) -> { [STATE y] } Eff t +locally : x -> (Eff t [STATE x]) -> Eff t [STATE y] locally newst prog = do st <- get                         putM newst                         val <- prog
libs/effects/Effect/StdIO.idr view
@@ -9,10 +9,10 @@  ||| The internal representation of StdIO effects data StdIO : Effect where-     PutStr : String -> { () } StdIO ()-     GetStr : { () } StdIO String-     PutCh : Char -> { () } StdIO ()-     GetCh : { () } StdIO Char+     PutStr : String -> sig StdIO ()+     GetStr : sig StdIO String+     PutCh : Char -> sig StdIO ()+     GetCh : sig StdIO Char   -------------------------------------------------------------@@ -39,33 +39,33 @@ STDIO = MkEff () StdIO  ||| Write a string to standard output.-putStr : String -> { [STDIO] } Eff ()+putStr : String -> Eff () [STDIO] putStr s = call $ PutStr s  ||| Write a string to standard output, terminating with a newline.-putStrLn : String -> { [STDIO] } Eff ()+putStrLn : String -> Eff () [STDIO] putStrLn s = putStr (s ++ "\n")  ||| Write a character to standard output.-putChar : Char -> { [STDIO] } Eff ()+putChar : Char -> Eff () [STDIO] putChar c = call $ PutCh c  ||| Write a character to standard output, terminating with a newline.-putCharLn : Char -> { [STDIO] } Eff ()+putCharLn : Char -> Eff () [STDIO] putCharLn c = putStrLn (singleton c)  ||| Read a string from standard input.-getStr : { [STDIO] } Eff String+getStr : Eff String [STDIO] getStr = call $ GetStr  ||| Read a character from standard input.-getChar : { [STDIO] } Eff Char+getChar : Eff Char [STDIO] getChar = call $ GetCh  ||| Given a parameter `a` 'show' `a` to standard output.-print : Show a => a -> { [STDIO] } Eff ()+print : Show a => a -> Eff () [STDIO] print a = putStr (show a)  ||| Given a parameter `a` 'show' `a` to a standard output, terminating with a newline-printLn : Show a => a -> { [STDIO] } Eff ()+printLn : Show a => a -> Eff () [STDIO] printLn a = putStrLn (show a)
libs/effects/Effect/System.idr view
@@ -8,10 +8,10 @@ import Control.IOExcept  data System : Effect where-     Args : { () } System (List String)-     Time : { () } System Int-     GetEnv : String -> { () } System (Maybe String)-     CSystem : String -> { () } System Int+     Args : sig System (List String)+     Time : sig System Int+     GetEnv : String -> sig System (Maybe String)+     CSystem : String -> sig System Int  instance Handler System IO where     handle () Args k = do x <- getArgs; k x ()@@ -30,14 +30,14 @@ SYSTEM : EFFECT SYSTEM = MkEff () System -getArgs : { [SYSTEM] } Eff (List String)+getArgs : Eff (List String) [SYSTEM] getArgs = call Args -time : { [SYSTEM] } Eff Int+time : Eff Int [SYSTEM] time = call Time -getEnv : String -> { [SYSTEM] } Eff (Maybe String)+getEnv : String -> Eff (Maybe String) [SYSTEM] getEnv s = call $ GetEnv s -system : String -> { [SYSTEM] } Eff Int+system : String -> Eff Int [SYSTEM] system s = call $ CSystem s
libs/effects/Effects.idr view
@@ -24,6 +24,28 @@ data EFFECT : Type where      MkEff : Type -> Effect -> EFFECT +-- 'sig' gives the signature for an effect. There are four versions+-- depending on whether there is no resource needed, +-- no state change, a non-dependent change,+-- or a dependent change. These are easily disambiguated by type.++namespace NoResourceEffect+  sig : Effect -> Type -> Type+  sig e r = e r () (\v => ())++namespace NoUpdateEffect+  sig : Effect -> (ret : Type) -> (resource : Type) -> Type+  sig e r e_in = e r e_in (\v => e_in)++namespace UpdateEffect+  sig : Effect -> (ret : Type) -> (res_in : Type) -> (res_out : Type) -> Type+  sig e r e_in e_out = e r e_in (\v => e_out)++namespace DepUpdateEffect+  sig : Effect -> +        (ret : Type) -> (res_in : Type) -> (res_out : ret -> Type) -> Type+  sig e r e_in e_out = e r e_in e_out+ ||| Handler classes describe how an effect `e` is translated to the ||| underlying computation context `m` for execution. class Handler (e : Effect) (m : Type -> Type) where@@ -60,6 +82,7 @@      Keep   : SubList xs ys -> SubList (x :: xs) (x :: ys)      Drop   : SubList xs ys -> SubList xs (x :: ys) +%hint subListId : SubList xs xs subListId {xs = Nil} = SubNil subListId {xs = x :: xs} = Keep subListId@@ -133,26 +156,61 @@ ||| @ x The return type of the result. ||| @ es The list of allowed side-effects. ||| @ ce Function to compute a new list of allowed side-effects.-data Eff : (x : Type)-           -> (es : List EFFECT)-           -> (ce : x -> List EFFECT) -> Type where-     value    : (val : a) -> Eff a (xs val) xs-     ebind    : Eff a xs xs' ->-                ((val : a) -> Eff b (xs' val) xs'') -> Eff b xs xs''+data EffM : (m : Type -> Type) -> (x : Type)+            -> (es : List EFFECT)+            -> (ce : x -> List EFFECT) -> Type where+     value    : (val : a) -> EffM m a (xs val) xs+     ebind    : EffM m a xs xs' ->+                ((val : a) -> EffM m b (xs' val) xs'') -> EffM m b xs xs''      callP    : (prf : EffElem e a xs) ->                 (eff : e t a b) ->-                Eff t xs (\v => updateResTy v xs prf eff)+                EffM m t xs (\v => updateResTy v xs prf eff)       liftP    : (prf : SubList ys xs) ->-                Eff t ys ys' -> Eff t xs (\v => updateWith (ys' v) xs prf)+                EffM m t ys ys' -> EffM m t xs (\v => updateWith (ys' v) xs prf) +     new      : Handler e' m => (e : EFFECT) -> resTy ->+                {auto prf : e = MkEff resTy e'} ->+                EffM m t (e :: es) (\v => e :: es) ->+                EffM m t es (\v => es)+      (:-)     : (l : ty) ->-                Eff t [x] xs' -> -- [x] (\v => xs) ->-                Eff t [l ::: x] (\v => map (l :::) (xs' v))+                EffM m t [x] xs' -> -- [x] (\v => xs) ->+                EffM m t [l ::: x] (\v => map (l :::) (xs' v)) +-- Some type synonyms, so we don't always have to write EffM in full++namespace SimpleEff+  -- Simple effects, no updates+  Eff : (x : Type) -> (es : List EFFECT) -> Type+  Eff x es = {m : Type -> Type} -> EffM m x es (\v => es)++  EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) -> Type+  EffT m x es = EffM m x es (\v => es)++namespace TransEff+  -- Dependent effects, updates not dependent on result+  Eff : (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type+  Eff x es ce = {m : Type -> Type} -> EffM m x es (\_ => ce)++  EffT : (m : Type -> Type) -> +         (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type+  EffT m x es ce = EffM m x es (\_ => ce)++namespace DepEff+  -- Dependent effects, updates dependent on result+  Eff : (x : Type) -> (es : List EFFECT) +        -> (ce : x -> List EFFECT) -> Type+  Eff x es ce = {m : Type -> Type} -> EffM m x es ce++  EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) +        -> (ce : x -> List EFFECT) -> Type+  EffT m x es ce = EffM m x es ce++ %no_implicit-(>>=)   : Eff a xs xs' ->-          ((val : a) -> Eff b (xs' val) xs'') -> Eff b xs xs''+(>>=)   : EffM m a xs xs' ->+          ((val : a) -> EffM m b (xs' val) xs'') -> EffM m b xs xs'' (>>=) = ebind  -- namespace SimpleBind@@ -161,29 +219,29 @@ --   (>>=) = ebind  ||| Run a subprogram which results in an effect state the same as the input.-staticEff : Eff a xs (\v => xs) -> Eff a xs (\v => xs)+staticEff : EffM m a xs (\v => xs) -> EffM m a xs (\v => xs) staticEff = id  ||| Explicitly give the expected set of result effects for an effectful ||| operation.-toEff : .(xs' : List EFFECT) -> Eff a xs (\v => xs') -> Eff a xs (\v => xs')+toEff : .(xs' : List EFFECT) -> EffM m a xs (\v => xs') -> EffM m a xs (\v => xs') toEff xs' = id -return : a -> Eff a xs (\v => xs)+return : a -> EffM m a xs (\v => xs) return x = value x  -- ------------------------------------------------------ [ for idiom brackets ]  infixl 2 <*> -pure : a -> Eff a xs (\v => xs)+pure : a -> EffM m a xs (\v => xs) pure = value -pureM : (val : a) -> Eff a (xs val) xs+pureM : (val : a) -> EffM m a (xs val) xs pureM = value -(<*>) : Eff (a -> b) xs (\v => xs) ->-        Eff a xs (\v => xs) -> Eff b xs (\v => xs)+(<*>) : EffM m (a -> b) xs (\v => xs) ->+        EffM m a xs (\v => xs) -> EffM m b xs (\v => xs) (<*>) prog v = do fn <- prog                   arg <- v                   return (fn arg)@@ -203,7 +261,7 @@ -- 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 a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b+eff : Env m xs -> EffM 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)@@ -211,6 +269,8 @@ eff env (liftP prf effP) k    = let env' = dropEnv env prf in          eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))+eff env (new (MkEff resTy newEff) res {prf=Refl} effP) k +   = eff (res :: env) effP (\p', (val :: envk) => k p' envk) -- FIXME: -- xs is needed explicitly because otherwise the pattern binding for -- 'l' appears too late. Solution seems to be to reorder patterns at the@@ -235,14 +295,14 @@        (eff : e t a b) ->        {default tactics { search 100; }           prf : EffElem e a xs} ->-      Eff t xs (\v => updateResTy v xs prf eff)+      EffM m t xs (\v => updateResTy v xs prf eff) call e {prf} = callP prf e  implicit-lift : Eff t ys ys' ->+lift : EffM m t ys ys' ->        {default tactics { search 100; }           prf : SubList ys xs} ->-       Eff t xs (\v => updateWith (ys' v) xs prf)+       EffM m t xs (\v => updateWith (ys' v) xs prf) lift e {prf} = liftP prf e  @@ -254,9 +314,11 @@ ||| implicit and initialised automatically. ||| ||| @prog The effectful program to run.-run : Applicative m => {default MkDefaultEnv env : Env m xs}-    -> (prog : Eff a xs xs') -> m a-run {env} prog = eff env prog (\r, env => pure r)+%no_implicit+run : Applicative m => +      (prog : EffM m a xs xs') -> {default MkDefaultEnv env : Env m xs} ->+      m a+run prog {env} = eff env prog (\r, env => pure r)  ||| Run an effectful program in the identity context. |||@@ -264,8 +326,10 @@ ||| The `env` argument is implicit and initialised automatically. ||| ||| @prog The effectful program to run.-runPure : {default MkDefaultEnv env : Env id xs} -> (prog : Eff a xs xs') -> a-runPure {env} prog = eff env prog (\r, env => r)+%no_implicit+runPure : (prog : EffM id a xs xs') -> +          {default MkDefaultEnv env : Env id xs} -> a +runPure prog {env} = eff env prog (\r, env => r)  ||| Run an effectful program in a given context `m` with a default value for the environment. |||@@ -273,7 +337,8 @@ ||| ||| @env The environment to use. ||| @prog The effectful program to run.-runInit : Applicative m => (env : Env m xs) -> (prog : Eff a xs xs') -> m a+%no_implicit+runInit : Applicative m => (env : Env m xs) -> (prog : EffM m a xs xs') -> m a runInit env prog = eff env prog (\r, env => pure r)  ||| Run an effectful program with a given default value for the environment.@@ -282,31 +347,34 @@ ||| ||| @env The environment to use. ||| @prog The effectful program to run.-runPureInit : (env : Env id xs) -> (prog : Eff a xs xs') -> a+%no_implicit+runPureInit : (env : Env id xs) -> (prog : EffM id a xs xs') -> a runPureInit env prog = eff env prog (\r, env => r) -runWith : (a -> m a) -> Env m xs -> Eff a xs xs' -> m a+%no_implicit+runWith : (a -> m a) -> Env m xs -> EffM m a xs xs' -> m a runWith inj env prog = eff env prog (\r, env => inj r) -runEnv : Applicative m => Env m xs -> Eff a xs xs' ->+%no_implicit+runEnv : Applicative m => Env m xs -> EffM 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 : (a -> {xs} Eff b) -> List a -> {xs} Eff (List b)+mapE : (a -> {xs} EffM m b) -> List a -> {xs} EffM m (List b) mapE f []        = pure [] mapE f (x :: xs) = [| f x :: mapE f xs |]  -mapVE : (a -> {xs} Eff b) ->+mapVE : (a -> {xs} EffM m b) ->         Vect n a ->-        {xs} Eff (Vect n b)+        {xs} EffM m (Vect n b) mapVE f []        = pure [] mapVE f (x :: xs) = [| f x :: mapVE f xs |]  -when : Bool -> Lazy ({xs} Eff ()) -> {xs} Eff ()+when : Bool -> Lazy ({xs} EffM m ()) -> {xs} EffM m () when True  e = Force e when False e = pure ()
libs/prelude/Builtins.idr view
@@ -23,11 +23,11 @@   ||| UniqueTypes.   ||| @A the type of the left elements in the pair   ||| @B the type of the left elements in the pair-  data UPair : (A : Type*) -> (B : Type*) -> Type where+  data UPair : (A : AnyType) -> (B : AnyType) -> AnyType where      ||| A pair of elements      ||| @a the left element of the pair      ||| @b the right element of the pair-     MkUPair : {A, B : Type*} -> (a : A) -> (b : B) -> UPair A B+     MkUPair : {A, B : AnyType} -> (a : A) -> (b : B) -> UPair A B    ||| Dependent pairs   |||@@ -36,7 +36,8 @@   ||| it. Another way to see dependent pairs is as just data - for instance, the   ||| length of a vector paired with that vector.   |||-  |||  @ a the type of the witness @ P the type of the proof+  |||  @ a the type of the witness+  |||  @ P the type of the proof   data Sigma : (a : Type) -> (P : a -> Type) -> Type where       MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P @@ -62,7 +63,7 @@ ||| @ x the left side ||| @ y the right side (~=~) : (x : a) -> (y : b) -> Type-(~=~) x y = (=) _ _ x y+(~=~) x y = (x = y)  ||| Perform substitution in a term according to some equality. |||@@ -149,3 +150,26 @@ public %assert_total really_believe_me : a -> b really_believe_me x = prim__believe_me _ _ x++-- Deprecated - for backward compatibility+Float : Type+Float = Double++-- Pointers as external primitive; there's no literals for these, so no+-- need for them to be part of the compiler.++abstract data Ptr : Type+abstract data ManagedPtr : Type++%extern prim__readFile : prim__WorldType -> Ptr -> String+%extern prim__writeFile : prim__WorldType -> Ptr -> String -> Int++%extern prim__vm : Ptr+%extern prim__stdin : Ptr+%extern prim__stdout : Ptr+%extern prim__stderr : Ptr++%extern prim__null : Ptr+%extern prim__registerPtr : Ptr -> Int -> ManagedPtr++
libs/prelude/IO.idr view
@@ -20,10 +20,11 @@ abstract WorldRes : Type -> Type WorldRes x = x -record FFI : Type where-     MkFFI : (ffi_types : Type -> Type) -> -             (ffi_fn : Type) -> -             (ffi_data : Type) -> FFI+record FFI where+  constructor MkFFI+  ffi_types : Type -> Type+  ffi_fn : Type+  ffi_data : Type  abstract  data IO' : (lang : FFI) -> Type -> Type where@@ -50,8 +51,10 @@ applyEnv [] f = f applyEnv (x@(_, _) :: xs) f = applyEnv xs (f x) -mkForeignPrim : ForeignPrimType xs env t--- compiled as primitive+mkForeignPrim : {xs : _} -> {ffi : _} -> {env : FEnv ffi xs} -> {t : Type} ->+                ForeignPrimType xs env t+-- compiled as primitive. Compiler assumes argument order, so make it+-- explicit here.  %inline foreign_prim : (f : FFI) -> @@ -117,57 +120,56 @@    = MkIO (\w => prim_io_return (prim__writeFile (world w) h s))  --------- The C FFI--data Raw : Type -> Type where-     -- code generated can assume it's compiled just as 't'-     MkRaw : (x : t) -> Raw t+namespace FFI_C+  data Raw : Type -> Type where+       -- code generated can assume it's compiled just as 't'+       MkRaw : (x : t) -> Raw t --- Tell erasure analysis not to erase the argument-%used MkRaw x+  -- Tell erasure analysis not to erase the argument+  %used MkRaw x --- Supported C integer types-data C_IntTypes : Type -> Type where-     C_IntChar   : C_IntTypes Char-     C_IntNative : C_IntTypes Int-     C_IntBits8  : C_IntTypes Bits8-     C_IntBits16 : C_IntTypes Bits16-     C_IntBits32 : C_IntTypes Bits32-     C_IntBits64 : C_IntTypes Bits64-     C_IntB8x16  : C_IntTypes Bits8x16-     C_IntB16x8  : C_IntTypes Bits16x8-     C_IntB32x4  : C_IntTypes Bits32x4-     C_IntB64x2  : C_IntTypes Bits64x2+  -- Supported C integer types+  data C_IntTypes : Type -> Type where+       C_IntChar   : C_IntTypes Char+       C_IntNative : C_IntTypes Int+       C_IntBits8  : C_IntTypes Bits8+       C_IntBits16 : C_IntTypes Bits16+       C_IntBits32 : C_IntTypes Bits32+       C_IntBits64 : C_IntTypes Bits64 --- Supported C foreign types-data C_Types : Type -> Type where-     C_Str   : C_Types String-     C_Float : C_Types Float-     C_Ptr   : C_Types Ptr-     C_MPtr  : C_Types ManagedPtr-     C_Unit  : C_Types ()-     C_Any   : C_Types (Raw a)-     C_IntT  : C_IntTypes i -> C_Types i+  -- Supported C foreign types+  data C_Types : Type -> Type where+       C_Str   : C_Types String+       C_Float : C_Types Float+       C_Ptr   : C_Types Ptr+       C_MPtr  : C_Types ManagedPtr+       C_Unit  : C_Types ()+       C_Any   : C_Types (Raw a)+       C_IntT  : C_IntTypes i -> C_Types i -FFI_C : FFI                                     -FFI_C = MkFFI C_Types String String+  FFI_C : FFI+  FFI_C = MkFFI C_Types String String  IO : Type -> Type IO = IO' FFI_C +-- Cannot be relaxed as is used by type providers and they expect IO a+-- in the first argument. run__provider : IO a -> PrimIO a run__provider (MkIO f) = f (TheWorld prim__TheWorld)  prim_fork : PrimIO () -> PrimIO Ptr prim_fork x = prim_io_return prim__vm -- compiled specially -fork : IO () -> IO Ptr-fork (MkIO f) = MkIO (\w => prim_io_bind-                              (prim_fork (prim_io_bind (f w)-                                   (\ x => prim_io_return x)))-                              (\x => prim_io_return x))+namespace IO+  fork : IO' l () -> IO' l Ptr+  fork (MkIO f) = MkIO (\w => prim_io_bind+                                (prim_fork (prim_io_bind (f w)+                                     (\ x => prim_io_return x)))+                                (\x => prim_io_return x)) -forceGC : IO ()-forceGC = foreign FFI_C "idris_forceGC" (Ptr -> IO ()) prim__vm+  forceGC : IO ()+  forceGC = foreign FFI_C "idris_forceGC" (Ptr -> IO ()) prim__vm  --------- The Javascript/Node FFI
libs/prelude/Language/Reflection.idr view
@@ -11,19 +11,36 @@  %access public -data TTName =-            ||| A user-provided name-            UN String |-            ||| A name in some namespace.-            |||-            ||| The namespace is in reverse order, so `(NS (UN "foo") ["B", "A"])` represents the name `A.B.foo`-            NS TTName (List String) |-            ||| Machine-chosen names-            MN Int String |-            ||| Name of something which is never used in scope-            NErased-%name TTName n, n'+mutual+  data TTName =+              ||| A user-provided name+              UN String |+              ||| A name in some namespace.+              |||+              ||| The namespace is in reverse order, so `(NS (UN "foo") ["B", "A"])`+              ||| represents the name `A.B.foo`+              NS TTName (List String) |+              ||| Machine-chosen names+              MN Int String |+              ||| Special names, to make conflicts impossible and language features+              ||| predictable+              SN SpecialName |+              ||| Name of something which is never used in scope+              NErased+  %name TTName n, n' +  data SpecialName = WhereN Int TTName TTName+                   | WithN Int TTName+                   | InstanceN TTName (List String)+                   | ParentN TTName String+                   | MethodN TTName+                   | CaseN TTName+                   | ElimN TTName+                   | InstanceCtorN TTName+                   | MetaN TTName TTName+++ implicit userSuppliedName : String -> TTName userSuppliedName = UN@@ -38,17 +55,14 @@ data NativeTy = IT8 | IT16 | IT32 | IT64  data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar-           | ITVec NativeTy Int  data ArithTy = ATInt Language.Reflection.IntTy | ATFloat  ||| Primitive constants data Const = I Int | BI Integer | Fl Float | Ch Char | Str String            | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64-           | B8V Bits8x16 | B16V Bits16x8-           | B32V Bits32x4 | B64V Bits64x2            | AType ArithTy | StrType-           | PtrType | ManagedPtrType | BufferType | VoidType | Forgot+           | VoidType | Forgot            | WorldType | TheWorld %name Const c, c' @@ -361,38 +375,6 @@   quotedTy = `(Integer)   quote x = RConstant (BI x) -instance Quotable Bits8x16 TT where-  quotedTy = `(Bits8x16)-  quote x = TConst (B8V x)--instance Quotable Bits8x16 Raw where-  quotedTy = `(Bits8x16)-  quote x = RConstant (B8V x)--instance Quotable Bits16x8 TT where-  quotedTy = `(Bits16x8)-  quote x = TConst (B16V x)--instance Quotable Bits16x8 Raw where-  quotedTy = `(Bits16x8)-  quote x = RConstant (B16V x)--instance Quotable Bits32x4 TT where-  quotedTy = `(Bits32x4)-  quote x = TConst (B32V x)--instance Quotable Bits32x4 Raw where-  quotedTy = `(Bits32x4)-  quote x = RConstant (B32V x)--instance Quotable Bits64x2 TT where-  quotedTy = `(Bits64x2)-  quote x = TConst (B64V x)--instance Quotable Bits64x2 Raw where-  quotedTy = `(Bits64x2)-  quote x = RConstant (B64V x)- instance Quotable String TT where   quotedTy = `(String)   quote x = TConst (Str x)@@ -425,20 +407,49 @@   quote [] = `(List.Nil {a=~(quotedTy {a})})   quote (x :: xs) = `(List.(::) {a=~(quotedTy {a})} ~(quote x) ~(quote xs)) -instance Quotable TTName TT where-  quotedTy = `(TTName)-  quote (UN x) = `(UN ~(quote x))-  quote (NS n xs) = `(NS ~(quote n) ~(quote xs))-  quote (MN x y) = `(MN ~(quote x) ~(quote y))-  quote NErased = `(NErased)+mutual+  instance Quotable TTName TT where+    quotedTy = `(TTName)+    quote (UN x) = `(UN ~(quote x))+    quote (NS n xs) = `(NS ~(quote n) ~(quote xs))+    quote (MN x y) = `(MN ~(quote x) ~(quote y))+    quote (SN sn) = `(SN ~(assert_total $ quote sn))+    quote NErased = `(NErased) -instance Quotable TTName Raw where-  quotedTy = `(TTName)-  quote (UN x) = `(UN ~(quote {t=Raw} x))-  quote (NS n xs) = `(NS ~(quote {t=Raw} n) ~(quote {t=Raw} xs))-  quote (MN x y) = `(MN ~(quote {t=Raw} x) ~(quote {t=Raw} y))-  quote NErased = `(NErased)+  instance Quotable SpecialName TT where+    quotedTy = `(SpecialName)+    quote (WhereN i n1 n2) = `(WhereN ~(quote i) ~(quote n1) ~(quote n2))+    quote (WithN i n) = `(WithN ~(quote i) ~(quote n))+    quote (InstanceN i ss) = `(InstanceN ~(quote i) ~(quote ss))+    quote (ParentN n s) = `(ParentN ~(quote n) ~(quote s))+    quote (MethodN n) = `(MethodN ~(quote n))+    quote (CaseN n) = `(CaseN ~(quote n))+    quote (ElimN n) = `(ElimN ~(quote n))+    quote (InstanceCtorN n) = `(InstanceCtorN ~(quote n))+    quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta)) +mutual+  instance Quotable TTName Raw where+    quotedTy = `(TTName)+    quote (UN x) = `(UN ~(quote {t=Raw} x))+    quote (NS n xs) = `(NS ~(quote {t=Raw} n) ~(quote {t=Raw} xs))+    quote (MN x y) = `(MN ~(quote {t=Raw} x) ~(quote {t=Raw} y))+    quote (SN sn) = `(SN ~(assert_total $ quote sn))+    quote NErased = `(NErased)++  instance Quotable SpecialName Raw where+    quotedTy = `(SpecialName)+    quote (WhereN i n1 n2) = `(WhereN ~(quote i) ~(quote n1) ~(quote n2))+    quote (WithN i n) = `(WithN ~(quote i) ~(quote n))+    quote (InstanceN i ss) = `(InstanceN ~(quote i) ~(quote ss))+    quote (ParentN n s) = `(ParentN ~(quote n) ~(quote s))+    quote (MethodN n) = `(MethodN ~(quote n))+    quote (CaseN n) = `(CaseN ~(quote n))+    quote (ElimN n) = `(ElimN ~(quote n))+    quote (InstanceCtorN n) = `(InstanceCtorN ~(quote n))+    quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta))++ instance Quotable NativeTy TT where     quotedTy = `(NativeTy)     quote IT8 = `(Reflection.IT8)@@ -459,7 +470,6 @@   quote ITNative = `(Reflection.ITNative)   quote ITBig = `(ITBig)   quote ITChar = `(Reflection.ITChar)-  quote (ITVec x y) = `(ITVec ~(quote x) ~(quote y))  instance Quotable Reflection.IntTy Raw where   quotedTy = `(Reflection.IntTy)@@ -467,7 +477,6 @@   quote ITNative = `(Reflection.ITNative)   quote ITBig = `(ITBig)   quote ITChar = `(Reflection.ITChar)-  quote (ITVec x y) = `(ITVec ~(quote {t=Raw} x) ~(quote {t=Raw} y))  instance Quotable ArithTy TT where   quotedTy = `(ArithTy)@@ -490,15 +499,8 @@   quote (B16 x) = `(B16 ~(quote x))   quote (B32 x) = `(B32 ~(quote x))   quote (B64 x) = `(B64 ~(quote x))-  quote (B8V xs) = `(B8V ~(quote xs))-  quote (B16V xs) = `(B16V ~(quote xs))-  quote (B32V xs) = `(B32V ~(quote xs))-  quote (B64V xs) = `(B64V ~(quote xs))   quote (AType x) = `(AType ~(quote x))   quote StrType = `(StrType)-  quote PtrType = `(PtrType)-  quote ManagedPtrType = `(ManagedPtrType)-  quote BufferType = `(BufferType)   quote VoidType = `(VoidType)   quote Forgot = `(Forgot)   quote WorldType = `(WorldType)@@ -515,15 +517,8 @@   quote (B16 x) = `(B16 ~(quote {t=Raw} x))   quote (B32 x) = `(B32 ~(quote {t=Raw} x))   quote (B64 x) = `(B64 ~(quote {t=Raw} x))-  quote (B8V xs) = `(B8V ~(quote {t=Raw} xs))-  quote (B16V xs) = `(B16V ~(quote {t=Raw} xs))-  quote (B32V xs) = `(B32V ~(quote {t=Raw} xs))-  quote (B64V xs) = `(B64V ~(quote {t=Raw} xs))   quote (AType x) = `(AType ~(quote {t=Raw} x))   quote StrType = `(StrType)-  quote PtrType = `(PtrType)-  quote ManagedPtrType = `(ManagedPtrType)-  quote BufferType = `(BufferType)   quote VoidType = `(VoidType)   quote Forgot = `(Forgot)   quote WorldType = `(WorldType)
+ libs/prelude/Language/Reflection/Elab.idr view
@@ -0,0 +1,331 @@+||| Primitives and tactics for elaborator reflection.+|||+||| Elaborator reflection allows Idris code to control Idris's+||| built-in elaborator, and re-use features like the unifier, the+||| type checker, and the hole mechanism.+module Language.Reflection.Elab++import Builtins+import Prelude.Applicative+import Prelude.Functor+import Prelude.List+import Prelude.Maybe+import Prelude.Monad+import Language.Reflection++||| Arguments, with plicity.+data Arg : Type where+  ||| An explicit argument+  Explicit : TTName -> Raw -> Arg++  ||| An implicit argument, to be solved by unification+  Implicit : TTName -> Raw -> Arg++  ||| A type-class constraint argument, to be solved by type class+  ||| resolution+  Constraint : TTName -> Raw -> Arg++||| A type declaration+data TyDecl : Type where+  ||| A type declaration.+  |||+  ||| Each argument is in the scope of the names of previous+  ||| arguments, and the return type is in the scope of all the+  ||| argument names.+  |||+  ||| @ fn the name to be declared, fully-qualified+  ||| @ args the arguments to the function+  ||| @ ret the final return type+  Declare : (fn : TTName) -> (args : List Arg) -> (ret : Raw) -> TyDecl++||| A single pattern-matching clause+data FunClause : Type where+  MkFunClause : (lhs, rhs : Raw) -> FunClause+  MkImpossibleClause : (lhs : Raw) -> FunClause++||| A reflected function definition.+data FunDefn : Type where+  DefineFun : TTName -> List FunClause -> FunDefn++||| An argument to a type constructor.+data TyConArg : Type where+  ||| Parameters are consistent across all constructors of the type+  Parameter : TTName -> Raw -> TyConArg++  ||| Indices are allowed to vary across constructors+  Index : TTName -> Raw -> TyConArg++||| A reflected datatype definition+data Datatype : Type where+  ||| A reflected datatype definition+  |||+  ||| @ familyName the name of the type constructor+  ||| @ tyConArgs the arguments to the type constructor+  ||| @ tyConRes the result of the type constructor+  ||| @ constrs the constructors, with their types+  MkDatatype : (familyName : TTName) ->+               (tyConArgs : List TyConArg) -> (tyConRes : Raw) ->+               (constrs : List (TTName, Raw)) ->+               Datatype++||| A reflected elaboration script.+abstract+data Elab : Type -> Type where+  -- obligatory control stuff+  prim__PureElab : a -> Elab a+  prim__BindElab : {a, b : Type} -> Elab a -> (a -> Elab b) -> Elab b++  prim__Try : {a : Type} -> Elab a -> Elab a -> Elab a+  prim__Fail : {a : Type} -> List ErrorReportPart -> Elab a++  prim__Env : Elab (List (TTName, Binder TT))+  prim__Goal : Elab (TTName, TT)+  prim__Holes : Elab (List TTName)+  prim__Guess : Elab (Maybe TT)+  prim__LookupTy : TTName -> Elab (List (TTName, NameType, TT))+  prim__LookupDatatype : TTName -> Elab (List Datatype)++  prim__SourceLocation : Elab SourceLocation++  prim__Forget : TT -> Elab Raw++  prim__Gensym : String -> Elab TTName++  prim__Solve : Elab ()+  prim__Fill : Raw -> Elab ()+  prim__Apply : Raw -> Elab ()+  prim__Focus : TTName -> Elab ()+  prim__Unfocus : TTName -> Elab ()+  prim__Attack : Elab ()++  prim__Rewrite : Raw -> Elab ()++  prim__Claim : TTName -> Raw -> Elab ()+  prim__Intro : Maybe TTName -> Elab ()+  prim__Forall : TTName -> Raw -> Elab ()+  prim__PatVar : TTName -> Elab ()+  prim__PatBind : TTName -> Elab ()++  prim__Compute : Elab ()++  prim__DeclareType : TyDecl -> Elab ()+  prim__DefineFunction : FunDefn -> Elab ()+  prim__AddInstance : TTName -> TTName -> Elab ()++  prim__ResolveTC : TTName -> Elab ()+  prim__RecursiveElab : Raw -> Elab () -> Elab (TT, TT)++  prim__Debug : {a : Type} -> Maybe String -> Elab a+++-------------+-- Public API+-------------+%access public+namespace Tactics+  instance Functor Elab where+    map f t = prim__BindElab t (\x => prim__PureElab (f x))++  instance Applicative Elab where+    pure x  = prim__PureElab x+    f <*> x = prim__BindElab f $ \g =>+              prim__BindElab x $ \y =>+              prim__PureElab   $ g y++  ||| The Alternative instance on Elab represents left-biased error+  ||| handling. In other words, `t <|> t'` will run `t`, and if it+  ||| fails, roll back the elaboration state and run `t'`.+  instance Alternative Elab where+    empty   = prim__Fail [TextPart "empty"]+    x <|> y = prim__Try x y++  instance Monad Elab where+    x >>= f = prim__BindElab x f++  ||| Halt elaboration with an error+  fail : List ErrorReportPart -> Elab a+  fail err = prim__Fail err++  ||| Look up the lexical binding at the focused hole+  getEnv : Elab (List (TTName, Binder TT))+  getEnv = prim__Env++  ||| Get the name and type of the focused hole+  getGoal : Elab (TTName, TT)+  getGoal = prim__Goal++  ||| Get the hole queue, in order+  getHoles : Elab (List TTName)+  getHoles = prim__Holes++  ||| If the current hole contains a guess, return it+  getGuess : Elab (Maybe TT)+  getGuess = prim__Guess++  ||| Look up the types of every overloading of a name+  lookupTy :  TTName -> Elab (List (TTName, NameType, TT))+  lookupTy n = prim__LookupTy n++  ||| Get the type of a fully-qualified name+  lookupTyExact : TTName -> Elab (TTName, NameType, TT)+  lookupTyExact n = case !(lookupTy n) of+                      [res] => return res+                      []    => fail [NamePart n, TextPart "is not defined."]+                      xs    => fail [NamePart n, TextPart "is ambiguous."]++  ||| Find the reflected representation of all datatypes whose names+  ||| are overloadings of some name+  lookupDatatype : TTName -> Elab (List Datatype)+  lookupDatatype n = prim__LookupDatatype n++  ||| Find the reflected representation of a datatype, given its+  ||| fully-qualified name.+  lookupDatatypeExact : TTName -> Elab Datatype+  lookupDatatypeExact n = case !(lookupDatatype n) of+                            [res] => return res+                            []    => fail [TextPart "No datatype named", NamePart n]+                            xs    => fail [TextPart "More than one datatype named", NamePart n]++  ||| Convert a type-annotated reflected term to its untyped+  ||| equivalent+  forgetTypes : TT -> Elab Raw+  forgetTypes tt = prim__Forget tt++  ||| Generate a unique name based on some hint.+  |||+  ||| **NB**: the generated name is unique _for this run of the+  ||| elaborator_. Do not assume that they are globally unique.+  gensym : (hint : String) -> Elab TTName+  gensym hint = prim__Gensym hint++  ||| Substitute a guess into a hole.+  solve : Elab ()+  solve = prim__Solve++  ||| Place a term into a hole, unifying its type+  fill : Raw -> Elab ()+  fill tm = prim__Fill tm++  ||| Fill with unification+  apply : Raw -> Elab ()+  apply tm = prim__Apply tm++  ||| Move the focus to the specified hole+  |||+  ||| @ hole the hole to focus on+  focus : (hole : TTName) -> Elab ()+  focus hole = prim__Focus hole++  ||| Send the currently-focused hole to the end of the hole queue and+  ||| focus on the next hole.+  unfocus : TTName -> Elab ()+  unfocus hole = prim__Unfocus hole++  ||| Convert a hole to make it suitable for bindings.+  |||+  ||| The binding tactics require that a hole be directly under its+  ||| binding, or else the scopes of the generated terms won't make+  ||| sense. This tactic creates a new hole of the proper form, and+  ||| points the old hole at it.+  attack : Elab ()+  attack = prim__Attack++  ||| Introduce a new hole with a specified name and type.+  |||+  ||| The new hole will be focused, and the previously-focused hole+  ||| will be immediately after it in the hole queue.+  claim : TTName -> Raw -> Elab ()+  claim n ty = prim__Claim n ty++  ||| Introduce a lambda binding around the current hole and focus on+  ||| the body. Requires that the hole be in binding form (use+  ||| `attack`).+  |||+  ||| @ n the name to use for the argument, or `Nothing` to use the name+  |||   in the corresponding hole type (a dependent function)+  intro : (n : Maybe TTName) -> Elab ()+  intro n = prim__Intro n++  ||| Introduce a dependent function type binding into the current hole,+  ||| and focus on the body.+  forall : TTName -> Raw -> Elab ()+  forall n ty = prim__Forall n ty++  ||| Convert a hole into a pattern variable.+  patvar : TTName -> Elab ()+  patvar n = prim__PatVar n++  ||| Introduce a new pattern binding.+  patbind : TTName -> Elab ()+  patbind n = prim__PatBind n++  ||| Normalise the goal.+  compute : Elab ()+  compute = prim__Compute++  ||| Find the source context for the elaboration script+  getSourceLocation : Elab SourceLocation+  getSourceLocation = prim__SourceLocation++  ||| Attempt to solve the current goal with the source code location+  sourceLocation : Elab ()+  sourceLocation = do loc <- getSourceLocation+                      fill (quote loc)+                      solve++  ||| Attempt to rewrite the goal using an equality.+  |||+  ||| The tactic searches the goal for applicable subterms, and+  ||| constructs a context for `replace` using them. In some cases,+  ||| this is not possible, and `replace` must be called manually with+  ||| an appropriate context.+  rewriteWith : Raw -> Elab ()+  rewriteWith rule = prim__Rewrite rule++  ||| Add a type declaration to the global context.+  declareType : TyDecl -> Elab ()+  declareType decl = prim__DeclareType decl++  ||| Define a function in the global context. The function must have+  ||| already been declared, either in ordinary Idris code or using+  ||| `declareType`.+  defineFunction : FunDefn -> Elab ()+  defineFunction defun = prim__DefineFunction defun++  ||| Register a new instance for type class resolution+  |||+  ||| @ className the name of the class for which an instance is being registered+  ||| @ instName the name of the definition to use in instance search+  addInstance : (className, instName : TTName) -> Elab ()+  addInstance className instName = prim__AddInstance className instName++  ||| Attempt to solve the current goal with a type class dictionary+  |||+  ||| @ fn the name of the definition being elaborated (to prevent Idris+  ||| from looping)+  resolveTC : (fn : TTName) -> Elab ()+  resolveTC fn = prim__ResolveTC fn++  ||| Halt elaboration, dumping the internal state for inspection.+  |||+  ||| This is intended for elaboration script developers, not for+  ||| end-users. Use `fail` for final scripts.+  debug : Elab a+  debug = prim__Debug Nothing++  ||| Halt elaboration, dumping the internal state and displaying a+  ||| message.+  |||+  ||| This is intended for elaboration script developers, not for+  ||| end-users. Use `fail` for final scripts.+  |||+  ||| @ msg the message to display+  debugMessage : (msg : String) -> Elab a+  debugMessage msg = prim__Debug (Just msg)++  ||| Recursively invoke the reflected elaborator with some goal.+  |||+  ||| The result is the final term and its type.+  runElab : Raw -> Elab () -> Elab (TT, TT)+  runElab goal script = prim__RecursiveElab goal script+
− libs/prelude/Language/Reflection/Tactical.idr 
@@ -1,138 +0,0 @@-module Language.Reflection.Tactical--import Builtins-import Prelude.Applicative-import Prelude.Functor-import Prelude.List-import Prelude.Maybe-import Prelude.Monad-import Language.Reflection--data Arg : Type where-  Explicit : TTName -> Raw -> Arg-  Implicit : TTName -> Raw -> Arg-  Constraint : TTName -> Raw -> Arg--data TyDecl : Type where-  Declare : TTName -> List Arg -> Raw -> TyDecl--abstract-data Tactical : Type -> Type where-  -- obligatory control stuff-  prim__PureTactical : a -> Tactical a-  prim__BindTactical : {a, b : Type} -> Tactical a -> (a -> Tactical b) -> Tactical b--  prim__Try : {a : Type} -> Tactical a -> Tactical a -> Tactical a-  prim__Fail : {a : Type} -> List ErrorReportPart -> Tactical a--  prim__Env : Tactical (List (TTName, Binder TT))-  prim__Goal : Tactical (TTName, TT)-  prim__Holes : Tactical (List TTName)-  prim__Guess : Tactical (Maybe TT)--  prim__SourceLocation : Tactical SourceLocation--  prim__Forget : TT -> Tactical Raw--  prim__Gensym : String -> Tactical TTName--  prim__Solve : Tactical ()-  prim__Fill : Raw -> Tactical ()-  prim__Focus : TTName -> Tactical ()-  prim__Unfocus : TTName -> Tactical ()-  prim__Attack : Tactical ()--  prim__Rewrite : Raw -> Tactical ()--  prim__Claim : TTName -> Raw -> Tactical ()-  prim__Intro : Maybe TTName -> Tactical ()--  prim__DeclareType : TyDecl -> Tactical ()--  prim__Debug : {a : Type} -> Maybe String -> Tactical a------------------- Public API---------------%access public--instance Functor Tactical where-  map f t = prim__BindTactical t (\x => prim__PureTactical (f x))--instance Applicative Tactical where-  pure x  = prim__PureTactical x-  f <*> x = prim__BindTactical f $ \g =>-            prim__BindTactical x $ \y =>-            prim__PureTactical   $ g y--instance Alternative Tactical where-  empty   = prim__Fail [TextPart "empty"]-  x <|> y = prim__Try x y--instance Monad Tactical where-  x >>= f = prim__BindTactical x f--fail : List ErrorReportPart -> Tactical a-fail err = prim__Fail err--getEnv : Tactical (List (TTName, Binder TT))-getEnv = prim__Env--getGoal : Tactical (TTName, TT)-getGoal = prim__Goal--getHoles : Tactical (List TTName)-getHoles = prim__Holes--getGuess : Tactical (Maybe TT)-getGuess = prim__Guess--forgetTypes : TT -> Tactical Raw-forgetTypes tt = prim__Forget tt--gensym : (hint : String) -> Tactical TTName-gensym hint = prim__Gensym hint--solve : Tactical ()-solve = prim__Solve--fill : Raw -> Tactical ()-fill tm = prim__Fill tm--focus : (hole : TTName) -> Tactical ()-focus hole = prim__Focus hole--unfocus : TTName -> Tactical ()-unfocus hole = prim__Unfocus hole--attack : Tactical ()-attack = prim__Attack--claim : TTName -> Raw -> Tactical ()-claim n ty = prim__Claim n ty--intro : Maybe TTName -> Tactical ()-intro n = prim__Intro n--||| Find out the present source context for the tactic script-getSourceLocation : Tactical SourceLocation-getSourceLocation = prim__SourceLocation--||| Attempt to solve the current goal with the source code location-sourceLocation : Tactical ()-sourceLocation = do loc <- getSourceLocation-                    fill (quote loc)-                    solve--rewriteWith : Raw -> Tactical ()-rewriteWith rule = prim__Rewrite rule--declareType : TyDecl -> Tactical ()-declareType decl = prim__DeclareType decl--debug : Tactical a-debug = prim__Debug Nothing--debugMessage : String -> Tactical a-debugMessage msg = prim__Debug (Just msg)
libs/prelude/Prelude.idr view
@@ -31,6 +31,12 @@ %access public %default total +-- Things that can't be elsewhere for import cycle reasons+decAsBool : Dec p -> Bool+decAsBool (Yes _) = True+decAsBool (No _)  = False++ -- Show and instances  class Show a where@@ -115,106 +121,6 @@ instance Show Bits64 where   show b = b64ToString b -%assert_total-viewB8x16 : Bits8x16 -> (Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8)-viewB8x16 x = ( prim__indexB8x16 x (prim__truncBigInt_B32 0)-              , prim__indexB8x16 x (prim__truncBigInt_B32 1)-              , prim__indexB8x16 x (prim__truncBigInt_B32 2)-              , prim__indexB8x16 x (prim__truncBigInt_B32 3)-              , prim__indexB8x16 x (prim__truncBigInt_B32 4)-              , prim__indexB8x16 x (prim__truncBigInt_B32 5)-              , prim__indexB8x16 x (prim__truncBigInt_B32 6)-              , prim__indexB8x16 x (prim__truncBigInt_B32 7)-              , prim__indexB8x16 x (prim__truncBigInt_B32 8)-              , prim__indexB8x16 x (prim__truncBigInt_B32 9)-              , prim__indexB8x16 x (prim__truncBigInt_B32 10)-              , prim__indexB8x16 x (prim__truncBigInt_B32 11)-              , prim__indexB8x16 x (prim__truncBigInt_B32 12)-              , prim__indexB8x16 x (prim__truncBigInt_B32 13)-              , prim__indexB8x16 x (prim__truncBigInt_B32 14)-              , prim__indexB8x16 x (prim__truncBigInt_B32 15)-              )--instance Show Bits8x16 where-  show x =-    case viewB8x16 x of-      (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =>-        "<" ++ prim__toStrB8 a-        ++ ", " ++ prim__toStrB8 b-        ++ ", " ++ prim__toStrB8 c-        ++ ", " ++ prim__toStrB8 d-        ++ ", " ++ prim__toStrB8 e-        ++ ", " ++ prim__toStrB8 f-        ++ ", " ++ prim__toStrB8 g-        ++ ", " ++ prim__toStrB8 h-        ++ ", " ++ prim__toStrB8 i-        ++ ", " ++ prim__toStrB8 j-        ++ ", " ++ prim__toStrB8 k-        ++ ", " ++ prim__toStrB8 l-        ++ ", " ++ prim__toStrB8 m-        ++ ", " ++ prim__toStrB8 n-        ++ ", " ++ prim__toStrB8 o-        ++ ", " ++ prim__toStrB8 p-        ++ ">"--%assert_total-viewB16x8 : Bits16x8 -> (Bits16, Bits16, Bits16, Bits16, Bits16, Bits16, Bits16, Bits16)-viewB16x8 x = ( prim__indexB16x8 x (prim__truncBigInt_B32 0)-              , prim__indexB16x8 x (prim__truncBigInt_B32 1)-              , prim__indexB16x8 x (prim__truncBigInt_B32 2)-              , prim__indexB16x8 x (prim__truncBigInt_B32 3)-              , prim__indexB16x8 x (prim__truncBigInt_B32 4)-              , prim__indexB16x8 x (prim__truncBigInt_B32 5)-              , prim__indexB16x8 x (prim__truncBigInt_B32 6)-              , prim__indexB16x8 x (prim__truncBigInt_B32 7)-              )--instance Show Bits16x8 where-  show x =-    case viewB16x8 x of-      (a, b, c, d, e, f, g, h) =>-        "<" ++ prim__toStrB16 a-        ++ ", " ++ prim__toStrB16 b-        ++ ", " ++ prim__toStrB16 c-        ++ ", " ++ prim__toStrB16 d-        ++ ", " ++ prim__toStrB16 e-        ++ ", " ++ prim__toStrB16 f-        ++ ", " ++ prim__toStrB16 g-        ++ ", " ++ prim__toStrB16 h-        ++ ">"--%assert_total-viewB32x4 : Bits32x4 -> (Bits32, Bits32, Bits32, Bits32)-viewB32x4 x = ( prim__indexB32x4 x (prim__truncBigInt_B32 0)-              , prim__indexB32x4 x (prim__truncBigInt_B32 1)-              , prim__indexB32x4 x (prim__truncBigInt_B32 2)-              , prim__indexB32x4 x (prim__truncBigInt_B32 3)-              )--instance Show Bits32x4 where-  show x =-    case viewB32x4 x of-      (a, b, c, d) =>-        "<" ++ prim__toStrB32 a-        ++ ", " ++ prim__toStrB32 b-        ++ ", " ++ prim__toStrB32 c-        ++ ", " ++ prim__toStrB32 d-        ++ ">"--%assert_total-viewB64x2 : Bits64x2 -> (Bits64, Bits64)-viewB64x2 x = ( prim__indexB64x2 x (prim__truncBigInt_B32 0)-              , prim__indexB64x2 x (prim__truncBigInt_B32 1)-              )--instance Show Bits64x2 where-  show x =-    case viewB64x2 x of-      (a, b) =>-        "<" ++ prim__toStrB64 a-        ++ ", " ++ prim__toStrB64 b-        ++ ">"- instance (Show a, Show b) => Show (a, b) where     show (x, y) = "(" ++ show x ++ ", " ++ show y ++ ")" @@ -228,6 +134,9 @@     show Nothing = "Nothing"     show (Just x) = "Just " ++ show x +instance (Show a, {y : a} -> Show (p y)) => Show (Sigma a p) where+    show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"+       ---- Functor instances  instance Functor PrimIO where@@ -336,8 +245,8 @@ total natEnumFromTo : Nat -> Nat -> List Nat natEnumFromTo n m = map (plus n) (natRange ((S m) - n)) total natEnumFromThenTo : Nat -> Nat -> Nat -> List Nat-natEnumFromThenTo _ Z   _ = []-natEnumFromThenTo n inc m = map (plus n . (* inc)) (natRange (S ((m - n) `div` inc)))+natEnumFromThenTo _ Z       _ = []+natEnumFromThenTo n (S inc) m = map (plus n . (* (S inc))) (natRange (S (divNatNZ (m - n) (S inc) SIsNotZ)))  class Enum a where   total pred : a -> a@@ -376,7 +285,7 @@           go [] = []           go (x :: xs) = n + cast x :: go xs   enumFromThenTo _ 0   _ = []-  enumFromThenTo n inc m = go (natRange (S (fromInteger (abs (m - n)) `div` fromInteger (abs inc))))+  enumFromThenTo n inc m = go (natRange (S (divNatNZ (fromInteger (abs (m - n))) (S (fromInteger ((abs inc) - 1))) SIsNotZ)))     where go : List Nat -> List Integer           go [] = []           go (x :: xs) = n + (cast x * inc) :: go xs@@ -396,7 +305,7 @@          go acc (S k) m = go (m :: acc) k (m - 1)   enumFromThen n inc = n :: enumFromThen (inc + n) inc   enumFromThenTo _ 0   _ = []-  enumFromThenTo n inc m = go (natRange (S (cast {to=Nat} (abs (m - n)) `div` cast {to=Nat} (abs inc))))+  enumFromThenTo n inc m = go (natRange (S (divNatNZ (cast {to=Nat} (abs (m - n))) (S (cast {to=Nat} ((abs inc) - 1))) SIsNotZ)))     where go : List Nat -> List Int           go [] = []           go (x :: xs) = n + (cast x * inc) :: go xs@@ -419,18 +328,6 @@ uncurry : (a -> b -> c) -> (a, b) -> c uncurry f (a, b) = f a b -uniformB8x16 : Bits8 -> Bits8x16-uniformB8x16 x = prim__mkB8x16 x x x x x x x x x x x x x x x x--uniformB16x8 : Bits16 -> Bits16x8-uniformB16x8 x = prim__mkB16x8 x x x x x x x x--uniformB32x4 : Bits32 -> Bits32x4-uniformB32x4 x = prim__mkB32x4 x x x x--uniformB64x2 : Bits64 -> Bits64x2-uniformB64x2 x = prim__mkB64x2 x x- ---- some basic io  ||| Output a string to stdout without a trailing newline@@ -452,10 +349,16 @@ printLn : Show a => a -> IO' ffi () printLn x = putStrLn (show x) -||| Read one line of input from stdin+||| Read one line of input from stdin, without the trailing newline partial getLine : IO' ffi String-getLine = prim_read+getLine = do x <- prim_read+             return (reverse (trimNL (reverse x)))+  where trimNL : String -> String+        trimNL str with (strM str)+          trimNL "" | StrNil = ""+          trimNL (strCons '\n' xs) | StrCons _ _ = xs+          trimNL (strCons x xs)    | StrCons _ _ = strCons x xs  ||| Write a single character to stdout partial@@ -632,7 +535,7 @@ ||| @ test the condition of the loop ||| @ body the loop body partial -- obviously-while : (test : IO Bool) -> (body : IO ()) -> IO ()+while : (test : IO' l Bool) -> (body : IO' l ()) -> IO' l () while t b = do v <- t                if v then do b                             while t b
libs/prelude/Prelude/Algebra.idr view
@@ -2,11 +2,7 @@  import Builtins --- XXX: change?-infixl 6 <-> infixl 6 <+>-infixl 6 <.>-infixl 5 <#>  %access public
libs/prelude/Prelude/Bits.idr view
@@ -5,6 +5,7 @@ import Prelude.Basics import Prelude.Bool import Prelude.Cast+import Prelude.Chars import Prelude.Classes import Prelude.Foldable import Prelude.Nat
libs/prelude/Prelude/Bool.idr view
@@ -11,12 +11,9 @@ ||| @ b the condition on the if ||| @ t the value if b is true ||| @ e the falue if b is false-boolElim : (b : Bool) -> (t : Lazy a) -> (e : Lazy a) -> a-boolElim True  t e = t-boolElim False t e = e---- Syntactic sugar for boolean elimination.-syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e)+ifThenElse : (b : Bool) -> (t : Lazy a) -> (e : Lazy a) -> a+ifThenElse True  t e = t+ifThenElse False t e = e  -- Boolean Operator Precedence infixl 4 &&, ||
libs/prelude/Prelude/Cast.idr view
@@ -1,5 +1,8 @@ module Prelude.Cast +import Prelude.Bool+import public Builtins+ ||| Type class for transforming a instance of a data type to another type. class Cast from to where     ||| Perform a cast operation.@@ -28,9 +31,6 @@  instance Cast Int Integer where     cast = prim__sextInt_BigInt--instance Cast Int Char where-    cast = prim__intToChar  -- Float casts
libs/prelude/Prelude/Chars.idr view
@@ -1,15 +1,21 @@-module Prelude.Char+module Prelude.Chars -- Functions operating over Chars  import Prelude.Bool import Prelude.Classes import Prelude.List+import Prelude.Cast import Builtins  ||| Return the ASCII representation of the character. chr : Int -> Char-chr x = prim__intToChar x+chr x = if (x >= 0 && x < 0x11000)+                then assert_total (prim__intToChar x)+                else '\0' +instance Cast Int Char where+    cast = chr+ ||| Convert the number to its ASCII equivalent. ord : Char -> Int ord x = prim__charToInt x@@ -48,14 +54,14 @@ ||| Non-letters are ignored. toUpper : Char -> Char toUpper x = if (isLower x)-               then (prim__intToChar (prim__charToInt x - 32))+               then assert_total (prim__intToChar (prim__charToInt x - 32))                else x  ||| Convert a letter to the corresponding lower-case letter, if any. ||| Non-letters are ignored. toLower : Char -> Char toLower x = if (isUpper x)-               then (prim__intToChar (prim__charToInt x + 32))+               then assert_total (prim__intToChar (prim__charToInt x + 32))                else x  ||| Returns true if the character is a hexadecimal digit i.e. in the range [0-9][a-f][A-F]
libs/prelude/Prelude/Classes.idr view
@@ -86,7 +86,7 @@     (>=) x y = x > y || x == y      max : a -> a -> a-    max x y = if (x > y) then x else y+    max x y = if x > y then x else y      min : a -> a -> a     min x y = if (x < y) then x else y@@ -315,10 +315,12 @@  -- ---------------------------------------------------------------- [ Integers ] divBigInt : Integer -> Integer -> Integer-divBigInt = prim__sdivBigInt+divBigInt x y = case y == 0 of+  False => prim__sdivBigInt x y  modBigInt : Integer -> Integer -> Integer-modBigInt = prim__sremBigInt+modBigInt x y = case y == 0 of+  False => prim__sremBigInt x y  instance Integral Integer where   div = divBigInt@@ -327,10 +329,12 @@ -- --------------------------------------------------------------------- [ Int ]  divInt : Int -> Int -> Int-divInt = prim__sdivInt+divInt x y = case y == 0 of+  False => prim__sdivInt x y  modInt : Int -> Int -> Int-modInt = prim__sremInt+modInt x y = case y == 0 of+  False => prim__sremInt x y  instance Integral Int where   div = divInt@@ -338,10 +342,12 @@  -- ------------------------------------------------------------------- [ Bits8 ] divB8 : Bits8 -> Bits8 -> Bits8-divB8 = prim__sdivB8+divB8 x y = case y == 0 of+  False => prim__sdivB8 x y  modB8 : Bits8 -> Bits8 -> Bits8-modB8 = prim__sremB8+modB8 x y = case y == 0 of+  False => prim__sremB8 x y    instance Integral Bits8 where   div = divB8@@ -349,10 +355,12 @@  -- ------------------------------------------------------------------ [ Bits16 ] divB16 : Bits16 -> Bits16 -> Bits16-divB16 = prim__sdivB16+divB16 x y = case y == 0 of+  False => prim__sdivB16 x y  modB16 : Bits16 -> Bits16 -> Bits16-modB16 = prim__sremB16+modB16 x y = case y == 0 of+  False => prim__sremB16 x y  instance Integral Bits16 where   div = divB16 @@ -360,10 +368,12 @@  -- ------------------------------------------------------------------ [ Bits32 ] divB32 : Bits32 -> Bits32 -> Bits32-divB32 = prim__sdivB32+divB32 x y = case y == 0 of+  False => prim__sdivB32 x y  modB32 : Bits32 -> Bits32 -> Bits32-modB32 = prim__sremB32+modB32 x y = case y == 0 of+  False => prim__sremB32 x y  instance Integral Bits32 where   div = divB32 @@ -371,10 +381,12 @@  -- ------------------------------------------------------------------ [ Bits64 ] divB64 : Bits64 -> Bits64 -> Bits64-divB64 = prim__sdivB64+divB64 x y = case y == 0 of+  False => prim__sdivB64 x y  modB64 : Bits64 -> Bits64 -> Bits64-modB64 = prim__sremB64+modB64 x y = case y == 0 of+  False => prim__sremB64 x y  instance Integral Bits64 where   div = divB64
libs/prelude/Prelude/Either.idr view
@@ -66,6 +66,11 @@ fromEither (Left l)  = l fromEither (Right r) = r +||| Right becomes left and left becomes right+mirror : Either a b -> Either b a+mirror (Left  x) = Right x+mirror (Right x) = Left x+ -------------------------------------------------------------------------------- -- Conversions --------------------------------------------------------------------------------
libs/prelude/Prelude/List.idr view
@@ -309,13 +309,12 @@ -- Folds -------------------------------------------------------------------------------- -||| A tail recursive right fold on Lists.-total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> List t -> acc-foldrImpl f e go [] = go e-foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs- instance Foldable List where-  foldr f e xs = foldrImpl f e id xs+  foldr c n [] = n+  foldr c n (x::xs) = c x (foldr c n xs)+  +  foldl f q [] = q+  foldl f q (x::xs) = foldl f (f q x) xs  -------------------------------------------------------------------------------- -- Special folds@@ -537,10 +536,11 @@ (\\) : (Eq a) => List a -> List a -> List a (\\) =  foldl (flip delete) +||| The unionBy function returns the union of two lists by user-supplied equality predicate. unionBy : (a -> a -> Bool) -> List a -> List a -> List a-unionBy eq xs ys =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs+unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs -||| The union function returns the list union of the two lists. For example,+||| Compute the union of two lists according to their `Eq` instance. ||| ||| ```idris example ||| union ['d', 'o', 'g'] ['c', 'o', 'w']@@ -808,6 +808,15 @@ ||| No list contains an element of the empty list. hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False hasAnyNilFalse l = ?hasAnyNilFalseBody++foldlAsFoldr : (b -> a -> b) -> b -> List a -> b+foldlAsFoldr f z t = foldr (flip (.) . flip f) id t z++||| The definition of foldl works the same as the default definition+||| in terms of foldr+foldlMatchesFoldr : (f : b -> a -> b) -> (q : b) -> (xs : List a) -> foldl f q xs = foldlAsFoldr f q xs+foldlMatchesFoldr f q [] = Refl+foldlMatchesFoldr f q (x :: xs) = foldlMatchesFoldr f (f q x) xs   --------------------------------------------------------------------------------
libs/prelude/Prelude/Maybe.idr view
@@ -78,17 +78,25 @@   (Just _) == Nothing  = False   (Just a) == (Just b) = a == b --- Lift a semigroup into 'Maybe' forming a 'Monoid' according to--- <http://en.wikipedia.org/wiki/Monoid>: "Any semigroup S may be--- turned into a monoid simply by adjoining an element i not in S--- and defining i+i = i and i+s = s = s+i for all s in S."+||| Prioritised choice. Just like the `Alternative` instance, the+||| `Semigroup` for `Maybe a` keeps the first succeeding computation.+|||+||| **NB**: This is a different choice than in the Haskell libraries.+||| Use `collectJust` to get the Haskell behaviour.+instance Semigroup (Maybe a) where+  Nothing   <+> m = m+  (Just x)  <+> _ = Just x -instance (Semigroup a) => Semigroup (Maybe a) where-  Nothing <+> m = m-  m <+> Nothing = m+||| Transform any semigroup into a monoid by using `Nothing` as the+||| designated neutral element and collecting the contents of the+||| `Just` constructors using a semigroup structure on `a`. This is+||| the behaviour in the Haskell libraries.+instance [collectJust] Semigroup a => Semigroup (Maybe a) where+  Nothing   <+> m       = m+  m         <+> Nothing = m   (Just m1) <+> (Just m2) = Just (m1 <+> m2) -instance (Semigroup a) => Monoid (Maybe a) where+instance  Monoid (Maybe a) where   neutral = Nothing  instance (Monoid a, Eq a) => Cast a (Maybe a) where@@ -98,5 +106,5 @@   cast = lowerMaybe  instance Foldable Maybe where-  foldr _ z Nothing = z+  foldr _ z Nothing  = z   foldr f z (Just x) = f x z
libs/prelude/Prelude/Nat.idr view
@@ -99,6 +99,9 @@   ||| If n <= m, then n + 1 <= m + 1   LTESucc : LTE left right -> LTE (S left) (S right) +instance Uninhabited (LTE (S n) Z) where+  uninhabited LTEZero impossible+ ||| Greater than or equal to total GTE : Nat -> Nat -> Type GTE left right = LTE right left@@ -127,6 +130,17 @@   isLTE (S k) (S j) | (Yes prf) = Yes (LTESucc prf)   isLTE (S k) (S j) | (No contra) = No (contra . fromLteSucc) +||| `LTE` is reflexive.+lteRefl : LTE n n+lteRefl {n = Z}   = LTEZero+lteRefl {n = S k} = LTESucc lteRefl++||| n < m implies n < m + 1+lteSuccRight : LTE n m -> LTE n (S m)+lteSuccRight LTEZero     = LTEZero+lteSuccRight (LTESucc x) = LTESucc (lteSuccRight x)++ ||| Boolean test than one Nat is less than or equal to another total lte : Nat -> Nat -> Bool lte Z        right     = True@@ -200,13 +214,15 @@   cast = fromInteger  ||| A wrapper for Nat that specifies the semigroup and monad instances that use (+)-record Multiplicative : Type where-  getMultiplicative : Nat -> Multiplicative+record Multiplicative where+  constructor getMultiplicative+  _ : Nat  ||| A wrapper for Nat that specifies the semigroup and monad instances that use (*)-record Additive : Type where-  getAdditive : Nat -> Additive-+record Additive where+  constructor getAdditive  +  _ : Nat+   instance Semigroup Multiplicative where   (<+>) left right = getMultiplicative $ left' * right'     where@@ -274,10 +290,12 @@ -- Division and modulus -------------------------------------------------------------------------------- -total-modNat : Nat -> Nat -> Nat-modNat left Z         = left-modNat left (S right) = mod' left left right+SIsNotZ : {x: Nat} -> (S x = Z) -> Void+SIsNotZ Refl impossible++modNatNZ : Nat -> (y: Nat) -> Not (y = Z) -> Nat+modNatNZ left Z         p = void (p Refl)+modNatNZ left (S right) _ = mod' left left right   where     total mod' : Nat -> Nat -> Nat -> Nat     mod' Z        centre right = centre@@ -287,10 +305,13 @@       else         mod' left (centre - (S right)) right -total-divNat : Nat -> Nat -> Nat-divNat left Z         = S left               -- div by zero-divNat left (S right) = div' left left right+partial+modNat : Nat -> Nat -> Nat+modNat left (S right) = modNatNZ left (S right) SIsNotZ++divNatNZ : Nat -> (y: Nat) -> Not (y = Z) -> Nat+divNatNZ left Z         p = void (p Refl)+divNatNZ left (S right) _ = div' left left right   where     total div' : Nat -> Nat -> Nat -> Nat     div' Z        centre right = Z@@ -300,23 +321,42 @@       else         S (div' left (centre - (S right)) right) +partial+divNat : Nat -> Nat -> Nat+divNat left (S right) = divNatNZ left (S right) SIsNotZ++divCeilNZ : Nat -> (y: Nat) -> Not (y = 0) -> Nat+divCeilNZ x y p = case (modNatNZ x y p) of+  Z   => divNatNZ x y p+  S _ => S (divNatNZ x y p)++partial+divCeil : Nat -> Nat -> Nat+divCeil x (S y) = divCeilNZ x (S y) SIsNotZ+ instance Integral Nat where   div = divNat   mod = modNat +log2NZ : (x: Nat) -> Not (x = Z) -> Nat+log2NZ Z         p = void (p Refl)+log2NZ (S Z)     _ = Z+log2NZ (S (S n)) _ = S (log2NZ (assert_smaller (S (S n)) (S (divNatNZ n 2 SIsNotZ))) SIsNotZ)++partial log2 : Nat -> Nat-log2 Z = Z-log2 (S Z) = Z-log2 n = S (log2 (assert_smaller n (n `divNat` 2)))+log2 (S n) = log2NZ (S n) SIsNotZ  -------------------------------------------------------------------------------- -- GCD and LCM --------------------------------------------------------------------------------+partial gcd : Nat -> Nat -> Nat gcd a Z = a gcd a b = assert_total (gcd b (a `modNat` b)) -total lcm : Nat -> Nat -> Nat+partial+lcm : Nat -> Nat -> Nat lcm _ Z = Z lcm Z _ = Z lcm x y = divNat (x * y) (gcd x y)@@ -592,31 +632,31 @@   let inductiveHypothesis = minusSuccPred left right in     ?minusSuccPredStepCase' --- boolElim-total boolElimSuccSucc : (cond : Bool) -> (t : Nat) -> (f : Nat) ->-  S (boolElim cond t f) = boolElim cond (S t) (S f)-boolElimSuccSucc True  t f = Refl-boolElimSuccSucc False t f = Refl+-- ifThenElse+total ifThenElseSuccSucc : (cond : Bool) -> (t : Nat) -> (f : Nat) ->+  S (ifThenElse cond t f) = ifThenElse cond (S t) (S f)+ifThenElseSuccSucc True  t f = Refl+ifThenElseSuccSucc False t f = Refl -total boolElimPlusPlusLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) ->-  left + (boolElim cond t f) = boolElim cond (left + t) (left + f)-boolElimPlusPlusLeft True  left t f = Refl-boolElimPlusPlusLeft False left t f = Refl+total ifThenElsePlusPlusLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) ->+  left + (ifThenElse cond t f) = ifThenElse cond (left + t) (left + f)+ifThenElsePlusPlusLeft True  left t f = Refl+ifThenElsePlusPlusLeft False left t f = Refl -total boolElimPlusPlusRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) ->-  (boolElim cond t f) + right = boolElim cond (t + right) (f + right)-boolElimPlusPlusRight True  right t f = Refl-boolElimPlusPlusRight False right t f = Refl+total ifThenElsePlusPlusRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) ->+  (ifThenElse cond t f) + right = ifThenElse cond (t + right) (f + right)+ifThenElsePlusPlusRight True  right t f = Refl+ifThenElsePlusPlusRight False right t f = Refl -total boolElimMultMultLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) ->-  left * (boolElim cond t f) = boolElim cond (left * t) (left * f)-boolElimMultMultLeft True  left t f = Refl-boolElimMultMultLeft False left t f = Refl+total ifThenElseMultMultLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) ->+  left * (ifThenElse cond t f) = ifThenElse cond (left * t) (left * f)+ifThenElseMultMultLeft True  left t f = Refl+ifThenElseMultMultLeft False left t f = Refl -total boolElimMultMultRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) ->-  (boolElim cond t f) * right = boolElim cond (t * right) (f * right)-boolElimMultMultRight True  right t f = Refl-boolElimMultMultRight False right t f = Refl+total ifThenElseMultMultRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) ->+  (ifThenElse cond t f) * right = ifThenElse cond (t * right) (f * right)+ifThenElseMultMultRight True  right t f = Refl+ifThenElseMultMultRight False right t f = Refl  -- Orders total lteNTrue : (n : Nat) -> lte n n = True@@ -710,11 +750,6 @@ sucMinR Z = Refl sucMinR (S l) = cong (sucMinR l) --- div and mod-total modZeroZero : (n : Nat) -> mod 0 n = Z-modZeroZero Z     = Refl-modZeroZero (S n) = Refl- -------------------------------------------------------------------------------- -- Proofs --------------------------------------------------------------------------------@@ -877,13 +912,13 @@  maximumSuccSuccStepCase = proof {     intros;-    rewrite sym (boolElimSuccSucc (lte left right) (S right) (S left));+    rewrite sym (ifThenElseSuccSucc (lte left right) (S right) (S left));     trivial; }  minimumSuccSuccStepCase = proof {     intros;-    rewrite (boolElimSuccSucc (lte left right) (S left) (S right));+    rewrite (ifThenElseSuccSucc (lte left right) (S left) (S right));     trivial; }
libs/prelude/Prelude/Pairs.idr view
@@ -5,6 +5,9 @@ %access public %default total +swap : (a, b) -> (b, a)+swap (x, y) = (y, x)+ using (a : Type, P : a -> Type)    ||| Dependent pair where the first field is erased.
libs/prelude/prelude.ipkg view
@@ -10,7 +10,7 @@           Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,           Prelude.Uninhabited, Prelude.Pairs, Prelude.Providers, -          Language.Reflection, Language.Reflection.Errors, Language.Reflection.Tactical,+          Language.Reflection, Language.Reflection.Errors, Language.Reflection.Elab,            Decidable.Equality
main/Main.hs view
@@ -29,6 +29,7 @@ import IRTS.System ( getLibFlags, getIdrisLibDir, getIncFlags )  import Util.DynamicLinker+import Util.System  import Pkg.Package @@ -43,6 +44,7 @@  runIdris :: [Opt] -> Idris () runIdris opts = do+       runIO setupBundledCC        when (ShowIncs `elem` opts) $ runIO showIncs        when (ShowLibs `elem` opts) $ runIO showLibs        when (ShowLibdir `elem` opts) $ runIO showLibdir
rts/Makefile view
@@ -1,10 +1,11 @@ include ../config.mk  OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_bitstring.o \-       idris_opts.o idris_stats.o mini-gmp.o+       idris_opts.o idris_stats.o idris_utf8.o mini-gmp.o getline.o HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_bitstring.h \-       idris_opts.h idris_stats.h mini-gmp.h idris_stdfgn.h idris_net.h-CFLAGS:=-fPIC $(CFLAGS)+       idris_opts.h idris_stats.h mini-gmp.h idris_stdfgn.h idris_net.h \+       idris_utf8.h getline.h+CFLAGS := $(CFLAGS) CFLAGS += $(GMP_INCLUDE_DIR) $(GMP) -DIDRIS_TARGET_OS="\"$(OS)\"" CFLAGS += -DIDRIS_TARGET_TRIPLE="\"$(MACHINE)\"" @@ -20,6 +21,7 @@ ifeq ($(OS), windows) 	OBJS += windows/idris_stdfgn.o windows/idris_net.o windows/win_utils.o else+	CFLAGS += -fPIC 	OBJS += idris_stdfgn.o idris_net.o endif
+ rts/getline.c view
@@ -0,0 +1,81 @@+/*  $NetBSD: fgetln.c,v 1.9 2008/04/29 06:53:03 martin Exp $  */++/*-+ * Copyright (c) 2011 The NetBSD Foundation, Inc.+ * All rights reserved.+ *+ * This code is derived from software contributed to The NetBSD Foundation+ * by Christos Zoulas.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions+ * are met:+ * 1. Redistributions of source code must retain the above copyright+ *    notice, this list of conditions and the following disclaimer.+ * 2. Redistributions in binary form must reproduce the above copyright+ *    notice, this list of conditions and the following disclaimer in the+ *    documentation and/or other materials provided with the distribution.+ *+ * THIS SOFTWARE IS PROVIDED BY THE NETBSD FOUNDATION, INC. AND CONTRIBUTORS+ * ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+ * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS+ * BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+ * POSSIBILITY OF SUCH DAMAGE.+ */++#include <stdlib.h>+#include <stdio.h>+#include <unistd.h>+#include <errno.h>+#include <string.h>++ssize_t+getdelim(char **buf, size_t *bufsiz, int delimiter, FILE *fp)+{+  char *ptr, *eptr;+++  if (*buf == NULL || *bufsiz == 0) {+    *bufsiz = BUFSIZ;+    if ((*buf = malloc(*bufsiz)) == NULL)+      return -1;+  }++  for (ptr = *buf, eptr = *buf + *bufsiz;;) {+    int c = fgetc(fp);+    if (c == -1) {+      if (feof(fp))+        return ptr == *buf ? -1 : ptr - *buf;+      else+        return -1;+    }+    *ptr++ = c;+    if (c == delimiter) {+      *ptr = '\0';+      return ptr - *buf;+    }+    if (ptr + 2 >= eptr) {+      char *nbuf;+      size_t nbufsiz = *bufsiz * 2;+      ssize_t d = ptr - *buf;+      if ((nbuf = realloc(*buf, nbufsiz)) == NULL)+        return -1;+      *buf = nbuf;+      *bufsiz = nbufsiz;+      eptr = nbuf + nbufsiz;+      ptr = nbuf + d;+    }+  }+}++ssize_t+getline(char **buf, size_t *bufsiz, FILE *fp)+{+  return getdelim(buf, bufsiz, '\n', fp);+}
+ rts/getline.h view
@@ -0,0 +1,7 @@+#ifndef GETLINE_H+#define GETLINE_H+#include <stdlib.h>+#include <stdio.h>+ssize_t getdelim(char **buf, size_t *bufsiz, int delimiter, FILE *fp);+ssize_t getline(char **buf, size_t *bufsiz, FILE *fp);+#endif // GETLINE_H
rts/idris_bitstring.c view
@@ -822,71 +822,3 @@     return cl; } -// SSE vectors-VAL idris_IDXB8x16(VM* vm, VAL vec, VAL idx) {-    __m128i sse = *vec->info.bits128p;-    uint8_t data[16];-    _mm_storeu_si128((__m128i*)&data, sse);-    return MKB8(vm, data[idx->info.bits32]);-}--VAL idris_IDXB16x8(VM* vm, VAL vec, VAL idx) {-    __m128i sse = *vec->info.bits128p;-    uint16_t data[8];-    _mm_storeu_si128((__m128i*)&data, sse);-    return MKB16(vm, data[idx->info.bits32]);-}--VAL idris_IDXB32x4(VM* vm, VAL vec, VAL idx) {-    __m128i sse = *vec->info.bits128p;-    uint32_t data[4];-    _mm_storeu_si128((__m128i*)&data, sse);-    return MKB32(vm, data[idx->info.bits32]);-}--VAL idris_IDXB64x2(VM* vm, VAL vec, VAL idx) {-     __m128i sse = *vec->info.bits128p;-    uint64_t data[2];-    _mm_storeu_si128((__m128i*)&data, sse);-    return MKB64(vm, data[idx->info.bits32]);-}--VAL idris_b8x16CopyForGC(VM *vm, VAL vec) {-    __m128i sse = *vec->info.bits128p;-    VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);-    SETTY(cl, BITS8X16);-    cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);-    assert ((uintptr_t)cl->info.bits128p % 16 == 0);-    *cl->info.bits128p = sse;-    return cl;-}--VAL idris_b16x8CopyForGC(VM *vm, VAL vec) {-    __m128i sse = *vec->info.bits128p;-    VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);-    SETTY(cl, BITS16X8);-    cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);-    assert ((uintptr_t)cl->info.bits128p % 16 == 0);-    *cl->info.bits128p = sse;-    return cl;-}--VAL idris_b32x4CopyForGC(VM *vm, VAL vec) {-    __m128i sse = *vec->info.bits128p;-    VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);-    SETTY(cl, BITS32X4);-    cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);-    assert ((uintptr_t)cl->info.bits128p % 16 == 0);-    *cl->info.bits128p = sse;-    return cl;-}--VAL idris_b64x2CopyForGC(VM *vm, VAL vec) {-    __m128i sse = *vec->info.bits128p;-    VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);-    SETTY(cl, BITS64X2);-    cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);-    assert ((uintptr_t)cl->info.bits128p % 16 == 0);-    *cl->info.bits128p = sse;-    return cl;-}
rts/idris_bitstring.h view
@@ -126,14 +126,4 @@ VAL idris_b64T16(VM *vm, VAL a); VAL idris_b64T32(VM *vm, VAL a); -VAL idris_IDXB8x16(VM* vm, VAL vec, VAL idx);-VAL idris_IDXB16x8(VM* vm, VAL vec, VAL idx);-VAL idris_IDXB32x4(VM* vm, VAL vec, VAL idx);-VAL idris_IDXB64x2(VM* vm, VAL vec, VAL idx);--VAL idris_b8x16CopyForGC(VM *vm, VAL a);-VAL idris_b16x8CopyForGC(VM *vm, VAL a);-VAL idris_b32x4CopyForGC(VM *vm, VAL a);-VAL idris_b64x2CopyForGC(VM *vm, VAL a);- #endif
rts/idris_gc.c view
@@ -30,9 +30,6 @@     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;@@ -54,20 +51,15 @@     case BITS64:         cl = idris_b64CopyForGC(vm, x);         break;-    case BITS8X16:-        cl = idris_b8x16CopyForGC(vm, x);-        break;-    case BITS16X8:-        cl = idris_b16x8CopyForGC(vm, x);-        break;-    case BITS32X4:-        cl = idris_b32x4CopyForGC(vm, x);-        break;-    case BITS64X2:-        cl = idris_b64x2CopyForGC(vm, x);-        break;     case FWD:         return x->info.ptr;+    case RAWDATA:+        {+            size_t size = x->info.size + sizeof(Closure);+            cl = allocate(size, 0);+            memcpy(cl, x, size);+        }+        break;     default:         break;     }
rts/idris_rts.c view
@@ -2,7 +2,9 @@  #include "idris_rts.h" #include "idris_gc.h"+#include "idris_utf8.h" #include "idris_bitstring.h"+#include "getline.h"  #ifdef HAS_PTHREAD static pthread_key_t vm_key;@@ -141,7 +143,10 @@ }  void* idris_alloc(size_t size) {-    return allocate(size, 0);+    Closure* cl = (Closure*) allocate(sizeof(Closure)+size, 0);+    SETTY(cl, RAWDATA);+    cl->info.size = size;+    return (void*)cl+sizeof(Closure); }  void* idris_realloc(void* old, size_t old_size, size_t size) {@@ -326,107 +331,6 @@     return cl; } -VAL MKB8x16const(VM* vm,-                 uint8_t v0,  uint8_t v1,  uint8_t v2,  uint8_t v3,-                 uint8_t v4,  uint8_t v5,  uint8_t v6,  uint8_t v7,-                 uint8_t v8,  uint8_t v9,  uint8_t v10, uint8_t v11,-                 uint8_t v12, uint8_t v13, uint8_t v14, uint8_t v15) {-    Closure* cl = allocate(sizeof(Closure) + sizeof(__m128i), 1);-    SETTY(cl, BITS8X16);--    cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);-    assert ((uintptr_t)cl->info.bits128p % 16 == 0);--    uint8_t data[16];-    data[0]=v0;   data[1]=v1;   data[2]=v2;   data[3]=v3;-    data[4]=v4;   data[5]=v5;   data[6]=v6;   data[7]=v7;-    data[8]=v8;   data[9]=v9;   data[10]=v10; data[11]=v11;-    data[12]=v12; data[13]=v13; data[14]=v14; data[15]=v15;--    *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);--    return cl;-}--VAL MKB8x16(VM* vm,-            VAL v0,  VAL v1,  VAL v2,  VAL v3,-            VAL v4,  VAL v5,  VAL v6,  VAL v7,-            VAL v8,  VAL v9,  VAL v10, VAL v11,-            VAL v12, VAL v13, VAL v14, VAL v15) {-    return MKB8x16const(vm,-        v0->info.bits8,  v1->info.bits8,  v2->info.bits8,  v3->info.bits8,-        v4->info.bits8,  v5->info.bits8,  v6->info.bits8,  v7->info.bits8,-        v8->info.bits8,  v9->info.bits8,  v10->info.bits8, v11->info.bits8,-        v12->info.bits8, v13->info.bits8, v14->info.bits8, v15->info.bits8);-}--VAL MKB16x8const(VM* vm,-                 uint16_t v0, uint16_t v1, uint16_t v2, uint16_t v3,-                 uint16_t v4, uint16_t v5, uint16_t v6, uint16_t v7) {-    Closure* cl = allocate(sizeof(Closure) + sizeof(__m128i), 1);-    SETTY(cl, BITS16X8);--    cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);-    assert ((uintptr_t)cl->info.bits128p % 16 == 0);--    uint16_t data[8];-    data[0]=v0; data[1]=v1; data[2]=v2; data[3]=v3;-    data[4]=v4; data[5]=v5; data[6]=v6; data[7]=v7;--    *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);-    return cl;--}--VAL MKB16x8(VM* vm,-            VAL v0, VAL v1, VAL v2, VAL v3,-            VAL v4, VAL v5, VAL v6, VAL v7) {-    return MKB16x8const(vm,-        v0->info.bits16, v1->info.bits16, v2->info.bits16, v3->info.bits16,-        v4->info.bits16, v5->info.bits16, v6->info.bits16, v7->info.bits16);-}--VAL MKB32x4const(VM* vm,-                 uint32_t v0, uint32_t v1, uint32_t v2, uint32_t v3) {-    Closure* cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);-    SETTY(cl, BITS64X2);--    cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);-    assert ((uintptr_t)cl->info.bits128p % 16 == 0);--    uint32_t data[4];-    data[0]=v0; data[1]=v1; data[2]=v2; data[3]=v3;--    *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);-    return cl;-}--VAL MKB32x4(VM* vm,-            VAL v0, VAL v1, VAL v2, VAL v3) {-    return MKB32x4const(vm,-        v0->info.bits32, v1->info.bits32, v2->info.bits32, v3->info.bits32);-}--VAL MKB64x2const(VM* vm, uint64_t v0, uint64_t v1) {-    Closure* cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);-    SETTY(cl, BITS64X2);--    cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);-    assert ((uintptr_t)cl->info.bits128p % 16 == 0);--    uint64_t data[2];-    data[0]=v0; data[1]=v1;--    *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);-    return cl;-}--VAL MKB64x2(VM* vm, VAL v0, VAL v1) {-    return MKB64x2const(vm,-        v0->info.bits64,-        v1->info.bits64);-}- void PROJECT(VM* vm, VAL r, int loc, int arity) {     int i;     for(i = 0; i < arity; ++i) {@@ -596,58 +500,26 @@ }  VAL idris_strlen(VM* vm, VAL l) {-    return MKINT((i_int)(strlen(GETSTR(l))));+    return MKINT((i_int)(idris_utf8_strlen(GETSTR(l)))); } -#define BUFSIZE 256- VAL idris_readStr(VM* vm, FILE* h) {-// Modified from 'safe-fgets.c' in the gdb distribution.-// (see http://www.gnu.org/software/gdb/current/)-    char *line_ptr;-    char* line_buf = (char *) malloc (BUFSIZE);-    int line_buf_size = BUFSIZE;--    /* points to last byte */-    line_ptr = line_buf + line_buf_size - 1;--    /* so we can see if fgets put a 0 there */-    *line_ptr = 1;-    if (fgets (line_buf, line_buf_size, h) == 0)-        return MKSTR(vm, "");--    /* we filled the buffer? */-    while (line_ptr[0] == 0 && line_ptr[-1] != '\n')-    {-        /* Make the buffer bigger and read more of the line */-        line_buf_size += BUFSIZE;-        {   /* limit the scope of new_line_buf to where it's needed for errors*/-            char *new_line_buf = realloc (line_buf, line_buf_size);-            if (new_line_buf == NULL)-            {-                fprintf(stderr, "Fatal Error: couldn't allocate a larger line buffer.");-                exit(EXIT_FAILURE);-            } else {-                line_buf = new_line_buf;-            }-        }-        /* points to last byte again */-        line_ptr = line_buf + line_buf_size - 1;-        /* so we can see if fgets put a 0 there */-        *line_ptr = 1;--        if (fgets (line_buf + line_buf_size - BUFSIZE - 1, BUFSIZE + 1, h) == 0)-           return MKSTR(vm, "");+    VAL ret;+    char *buffer = NULL;+    size_t n = 0;+    ssize_t len;+    len = getline(&buffer, &n, h);+    if (len <= 0) {+        ret = MKSTR(vm, "");+    } else {+        ret = MKSTR(vm, buffer);     }--    VAL str = MKSTR(vm, line_buf);-//    printf("DBG: %s\n", line_buf);-    free(line_buf);-    return str;+    free(buffer);+    return ret; }  VAL idris_strHead(VM* vm, VAL str) {-    return MKINT((i_int)(GETSTR(str)[0]));+    return idris_strIndex(vm, str, 0); }  VAL MKSTROFFc(VM* vm, StrOffset* off) {@@ -679,27 +551,41 @@         }          cl->info.str_offset->str = root;-        cl->info.str_offset->offset = offset+1;+        cl->info.str_offset->offset = offset+idris_utf8_charlen(GETSTR(str));          return cl;     } else {-        return MKSTR(vm, GETSTR(str)+1);+        char* nstr = GETSTR(str);+        return MKSTR(vm, nstr+idris_utf8_charlen(nstr));     } }  VAL idris_strCons(VM* vm, VAL x, VAL xs) {     char *xstr = GETSTR(xs);-    Closure* cl = allocate(sizeof(Closure) +-                           strlen(xstr) + 2, 0);-    SETTY(cl, STRING);-    cl -> info.str = (char*)cl + sizeof(Closure);-    cl -> info.str[0] = (char)(GETINT(x));-    strcpy(cl -> info.str+1, xstr);-    return cl;+    int xval = GETINT(x);+    if ((xval & 0x80) == 0) { // ASCII char+        Closure* cl = allocate(sizeof(Closure) ++                               strlen(xstr) + 2, 0);+        SETTY(cl, STRING);+        cl -> info.str = (char*)cl + sizeof(Closure);+        cl -> info.str[0] = (char)(GETINT(x));+        strcpy(cl -> info.str+1, xstr);+        return cl;+    } else {+        char *init = idris_utf8_fromChar(xval);+        Closure* cl = allocate(sizeof(Closure) + strlen(init) + strlen(xstr) + 1, 0);+        SETTY(cl, STRING);+        cl -> info.str = (char*)cl + sizeof(Closure);+        strcpy(cl -> info.str, init);+        strcat(cl -> info.str, xstr);+        free(init);+        return cl;+    } }  VAL idris_strIndex(VM* vm, VAL str, VAL i) {-    return MKINT((i_int)(GETSTR(str)[GETINT(i)]));+    int idx = idris_utf8_index(GETSTR(str), GETINT(i));+    return MKINT((i_int)idx); }  VAL idris_strRev(VM* vm, VAL str) {@@ -707,14 +593,8 @@     Closure* cl = allocate(sizeof(Closure) +                            strlen(xstr) + 1, 0);     SETTY(cl, STRING);-    cl -> info.str = (char*)cl + sizeof(Closure);-    int y = 0;-    int x = strlen(xstr);--    cl-> info.str[x+1] = '\0';-    while(x>0) {-        cl -> info.str[y++] = xstr[--x];-    }+    cl->info.str = (char*)cl + sizeof(Closure);+    idris_utf8_rev(xstr, cl->info.str);     return cl; } @@ -731,240 +611,6 @@     return MKSTR(vm, ""); } -VAL MKBUFFERc(VM* vm, Buffer* buf) {-    Closure* cl = allocate(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(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_buffer_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@@ -1049,9 +695,6 @@     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;@@ -1072,6 +715,13 @@         break;     case BITS64:         cl = idris_b64CopyForGC(vm, x);+        break;+    case RAWDATA:+        {+            size_t size = x->info.size + sizeof(Closure);+            cl = allocate(size, 0);+            memcpy(cl, x, size);+        }         break;     default:         assert(0); // We're in trouble if this happens...
rts/idris_rts.h view
@@ -10,8 +10,6 @@ #endif #include <stdint.h> -#include <emmintrin.h>- #include "idris_heap.h" #include "idris_stats.h" @@ -26,8 +24,7 @@ typedef enum {     CON, INT, BIGINT, FLOAT, STRING, STROFFSET,     BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD,-    MANAGEDPTR, BUFFER, BITS8X16, BITS16X8, BITS32X4,-    BITS64X2+    MANAGEDPTR, RAWDATA } ClosureType;  typedef struct Closure *VAL;@@ -42,14 +39,6 @@     size_t 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;- // A foreign pointer, managed by the idris GC typedef struct {     size_t size;@@ -74,9 +63,8 @@         uint16_t bits16;         uint32_t bits32;         uint64_t bits64;-        __m128i* bits128p;-        Buffer* buf;         ManagedPtr* mptr;+        size_t size;     } info; } Closure; @@ -208,37 +196,12 @@ VAL MKB32(VM* vm, uint32_t b); VAL MKB64(VM* vm, uint64_t b); -// SSE Vectors-VAL MKB8x16(VM* vm,-            VAL v0, VAL v1, VAL v2, VAL v3,-            VAL v4, VAL v5, VAL v6, VAL v7,-            VAL v8, VAL v9, VAL v10, VAL v11,-            VAL v12, VAL v13, VAL v14, VAL v15);-VAL MKB8x16const(VM* vm,-                 uint8_t v0, uint8_t v1, uint8_t v2, uint8_t v3,-                 uint8_t v4, uint8_t v5, uint8_t v6, uint8_t v7,-                 uint8_t v8, uint8_t v9, uint8_t v10, uint8_t v11,-                 uint8_t v12, uint8_t v13, uint8_t v14, uint8_t v15);-VAL MKB16x8(VM* vm,-            VAL v0, VAL v1, VAL v2, VAL v3,-            VAL v4, VAL v5, VAL v6, VAL v7);-VAL MKB16x8const(VM* vm,-                 uint16_t v0, uint16_t v1, uint16_t v2, uint16_t v3,-                 uint16_t v4, uint16_t v5, uint16_t v6, uint16_t v7);-VAL MKB32x4(VM* vm,-            VAL v0, VAL v1, VAL v2, VAL v3);-VAL MKB32x4const(VM* vm,-                 uint32_t v0, uint32_t v1, uint32_t v2, uint32_t v3);-VAL MKB64x2(VM* vm, VAL v0, VAL v1);-VAL MKB64x2const(VM* vm, uint64_t v0, uint64_t v1);- // following versions don't take a lock when allocating VAL MKFLOATc(VM* vm, double val); VAL MKSTROFFc(VM* vm, StrOffset* off); VAL MKSTRc(VM* vm, char* str); VAL MKPTRc(VM* vm, void* ptr); VAL MKMPTRc(VM* vm, void* ptr, size_t size);-VAL MKBUFFERc(VM* vm, Buffer* buf);  char* GETSTROFF(VAL stroff); @@ -335,33 +298,11 @@  VAL idris_strHead(VM* vm, VAL str); VAL idris_strTail(VM* vm, VAL str);+// This is not expected to be efficient! Mostly we wouldn't expect to call+// it at all at run time. 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_buffer_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);  // system infox // used indices:
+ rts/idris_utf8.c view
@@ -0,0 +1,144 @@+#include "idris_utf8.h"+#include <stdio.h>+#include <string.h>+#include <stdlib.h>++int idris_utf8_strlen(char *s) {+   int i = 0, j = 0;+   while (s[i]) {+     if ((s[i] & 0xc0) != 0x80) j++;+     i++;+   }+   return j;+}++int idris_utf8_charlen(char* s) {+    int init = (int)s[0];+    if ((init & 0x80) == 0) {+        return 1; // Top bit unset, so 1 byte+    }+    if ((init > 244 && init < 256) ||+        (init == 192) ||+        (init == 193)) {+        return 1; // Invalid characters+    }+    int i = 1;+    while ((s[i] & 0xc0) == 0x80) {+        i++; // Move on until top 2 bits are not 10+    }+    return i;+}++unsigned idris_utf8_index(char* s, int idx) {+   int i = 0, j = 0;+   while (j < idx) {+     if ((s[i] & 0xc0) != 0x80) j++;+     i++;+   }+   // Find the start of the next character+   while ((s[i] & 0xc0) == 0x80) { i++; }++   unsigned bytes = 0;+   unsigned top = 0;++   int init = (int)s[1];++   // s[i] is now the start of the character we want+   if ((s[i] & 0x80) == 0) {+       bytes = 1;+       top = (int)(s[i]);+   } else if ((init > 244 && init < 256) ||+              (init == 192) ||+              (init == 193)) {+       bytes = 1;+       top = (int)(s[i]); // Invalid characters+   } else if ((s[i] & 0xe0) == 0xc0) {+       bytes = 2;+       top = (int)(s[i] & 0x1f); // 5 bits+   } else if ((s[i] & 0xf0) == 0xe0) {+       bytes = 3;+       top = (int)(s[i] & 0x0f); // 4 bits+   } else if ((s[i] & 0xf8) == 0xf0) {+       bytes = 4;+       top = (int)(s[i] & 0x07); // 3 bits+   } else if ((s[i] & 0xfc) == 0xf8) {+       bytes = 5;+       top = (int)(s[i] & 0x03); // 2 bits+   } else if ((s[i] & 0xfe) == 0xfc) {+       bytes = 6;+       top = (int)(s[i] & 0x01); // 1 bits+   }++   while (bytes > 1) {+       top = top << 6;+       top += s[++i] & 0x3f; // 6 bits+       --bytes;+   }++   return top;+}++char* idris_utf8_fromChar(int x) {+    char* str;+    int bytes = 0, top = 0;++    if ((x & 0x80) == 0) {+        str = malloc(2);+        str[0] = (char)x;+        str[1] = '\0';+        return str;+    }++    if (x >= 0x80 && x <= 0x7ff) {+        bytes = 2;+        top = 0xc0;+    } else if (x >= 0x800 && x <= 0xffff) {+        bytes = 3;+        top = 0xe0;+    } else if (x >= 0x10000 && x <= 0x10ffff) {+        bytes = 4;+        top = 0xf0;+    }++    str = malloc(bytes + 1);+    str[bytes] = '\0';+    while(bytes > 0) {+        int xbits = x & 0x3f; // Next 6 bits+        bytes--;+        if (bytes > 0) {+            str[bytes] = (char)xbits + 0x80;+        } else {+            str[0] = (char)xbits + top;+        }+        x = x >> 6;+    }++    return str;+}++void reverse_range(char *start, char *end)+{+    while(start < end)+    {+        char c = *start;+        *start++ = *end;+        *end-- = c;+    }+}++char* reverse_char(char *start)+{+    char *end = start;+    while((end[1] & 0xc0) == 0x80) { end++; }+    reverse_range(start, end);+    return(end + 1);+}++char* idris_utf8_rev(char* s, char* result) {+    strcpy(result, s);+    char* end = result;+    while(*end) { end = reverse_char(end); }+    reverse_range(result, end-1);+    return result;+}+
+ rts/idris_utf8.h view
@@ -0,0 +1,22 @@+#ifndef _IDRIS_UTF8+#define _IDRIS_UTF8++/* Various functions for dealing with UTF8 encoding. These are probably+   not very efficient (and I'm (EB) making no guarantees about their+   correctness.) Nevertheless, they mean that we can treat Strings as+   UFT8. Patches welcome :). */++// Get length of a UTF8 encoded string in characters+int idris_utf8_strlen(char *s);+// Get number of bytes the first character takes in a string+int idris_utf8_charlen(char* s);+// Return int representation of string at an index.+// Assumes in bounds.+unsigned idris_utf8_index(char* s, int j);+// Convert a char as an integer to a char* as a byte sequence+// Null terminated; caller responsible for freeing+char* idris_utf8_fromChar(int x);+// Reverse a UTF8 encoded string, putting the result in 'result'+char* idris_utf8_rev(char* s, char* result);++#endif
src/IRTS/CodegenC.hs view
@@ -12,8 +12,8 @@  import Numeric import Data.Char+import Data.Bits import Data.List (intercalate)-import qualified Data.Vector.Unboxed as V import System.Process import System.Exit import System.IO@@ -73,11 +73,12 @@              comp <- getCC              libFlags <- getLibFlags              incFlags <- getIncFlags+             envFlags <- getEnvFlags              let args = [gccDbg dbg] ++                         gccFlags iface ++                         -- # Any flags defined here which alter the RTS API must also be added to config.mk                         ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS", "-msse2",-                         "-I."] ++ objs ++ ["-x", "c"] +++                         "-I."] ++ objs ++ ["-x", "c"] ++ envFlags ++                         (if (exec == Executable) then [] else ["-c"]) ++                         [tmpn] ++                         (if not iface then concatMap words libFlags else []) ++@@ -145,9 +146,27 @@         | 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+        | otherwise = showHexes (utf8bytes (ord c)) +    utf8bytes :: Int -> [Int]+    utf8bytes x = let (h : bytes) = split [] x in+                      headHex h (length bytes) : map toHex bytes+      where+        split acc 0 = acc+        split acc x = let xbits = x .&. 0x3f +                          xrest = shiftR x 6 in+                          split (xbits : acc) xrest++        headHex h 1 = h + 0xc0+        headHex h 2 = h + 0xe0+        headHex h 3 = h + 0xf0+        headHex h n = error "Can't happen: Invalid UTF8 character"++        toHex i = i + 0x80++    showHexes = foldr ((++) . showUTF8) ""+    showUTF8 c = "\"\"\\x" ++ showHex c "\"\""+ bcc :: Int -> BC -> String bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n" bcc i (ASSIGNCONST l c)@@ -163,10 +182,6 @@     mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"     mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"     mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"-    mkConst (B8V  x) = let x' = V.toList x in "MKB8x16const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")"-    mkConst (B16V x) = let x' = V.toList x in "MKB16x8const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")"-    mkConst (B32V x) = let x' = V.toList x in "MKB32x4const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "UL") x') ++ ")"-    mkConst (B64V x) = let x' = V.toList x in "MKB64x2const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "ULL") x') ++ ")"     -- if it's a type constant, we won't use it, but equally it shouldn't     -- report an error. These might creep into generated for various reasons     -- (especially if erasure is disabled).@@ -206,11 +221,11 @@                     indent i ++ "}\n"      showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String-    showCase i Nothing [(t, c)] = showCode i c-    showCase i (Just def) [] = showCode i def+    showCase i Nothing [(t, c)] = indent i ++ showCode i c+    showCase i (Just def) [] = indent i ++ showCode i def     showCase i def ((t, c) : cs)         = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c-           ++ indent i ++ "else " ++ showCase i def cs+           ++ indent i ++ "else\n" ++ showCase i def cs  bcc i (CASE safe r code def)     = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++@@ -293,7 +308,7 @@                    (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"     where fcall (t, arg) = irts_c (toFType t) (creg arg) bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed-bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1); exit(-1);"+bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n" -- bcc i c = error (show c) -- indent i ++ "// not done yet\n"  -- Deconstruct the Foreign type in the defunctionalised expression and build@@ -305,10 +320,6 @@     | i == sUN "C_IntBits16" = ATInt (ITFixed IT16)     | i == sUN "C_IntBits32" = ATInt (ITFixed IT32)     | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)-    | i == sUN "C_IntB8x16" = ATInt (ITVec IT8 16)-    | i == sUN "C_IntB16x8" = ATInt (ITVec IT16 8)-    | i == sUN "C_IntB32x4" = ATInt (ITVec IT32 4)-    | i == sUN "C_IntB64x2" = ATInt (ITVec IT64 2) toAType t = error (show t ++ " not defined in toAType")  toFType (FCon c) @@ -424,11 +435,6 @@ doOp v (LSGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LSGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")" -doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"- doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")" doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")" doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"@@ -441,16 +447,6 @@ doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")" doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")" -doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"-doOp v LWriteStr [_,s] = v ++ "MKINT((i_int)(idris_writeStr(stdout"-                             ++ ",GETSTR("-                             ++ creg s ++ "))))"--doOp v LReadFile [_,x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"-doOp v LWriteFile [_,x,s] = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x-                              ++ "),GETSTR("-                              ++ creg s ++ "))))"- doOp v (LSLt (ATInt (ITFixed ty))) [x, y] = bitOp v "SLt" ty [x, y] doOp v (LSLe (ATInt (ITFixed ty))) [x, y] = bitOp v "SLte" ty [x, y] doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]@@ -529,46 +525,56 @@ doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x) doOp v LFNegate [x] = v ++ "MKFLOAT(vm, -GETFLOAT(" ++ (creg x) ++ "))" +-- String functions which don't need to know we're UTF8+doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"++doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"+doOp v LWriteStr [_,s] +             = v ++ "MKINT((i_int)(idris_writeStr(stdout"+                 ++ ",GETSTR("+                 ++ creg s ++ "))))"+++-- String functions which need to know we're UTF8 doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")" doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")" doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")" 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_buffer_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 LStrLen [x] = v ++ "idris_strlen(vm, " ++ 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)"-doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++-                                  "), GETINT(" ++ creg i ++ "))" doOp v (LChInt ITNative) args = v ++ creg (last args) doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args doOp v (LIntCh ITNative) args = v ++ creg (last args) doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args -doOp v c@(LMkVec IT8  _) args = v ++ "MKB8x16(vm, " ++  (intercalate ", " (map creg args)) ++ ")"-doOp v c@(LMkVec IT16 _) args = v ++ "MKB16x8(vm, " ++ (intercalate ", " (map creg args)) ++ ")"-doOp v c@(LMkVec IT32 _) args = v ++ "MKB32x4(vm, " ++ (intercalate ", " (map creg args)) ++ ")"-doOp v c@(LMkVec IT64 _) args = v ++ "MKB64x2(vm, " ++ (intercalate ", " (map creg args)) ++ ")"--doOp v c@(LIdxVec IT8  _) [p, i] = v ++ "idris_IDXB8x16(vm, " ++ creg p ++ ", " ++ creg i ++ ")"-doOp v c@(LIdxVec IT16 _) [p, i] = v ++ "idris_IDXB16x8(vm, " ++ creg p ++ ", " ++ creg i ++ ")"-doOp v c@(LIdxVec IT32 _) [p, i] = v ++ "idris_IDXB32x4(vm, " ++ creg p ++ ", " ++ creg i ++ ")"-doOp v c@(LIdxVec IT64 _) [p, i] = v ++ "idris_IDXB64x2(vm, " ++ creg p ++ ", " ++ creg i ++ ")"- doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")" doOp v LNoOp args = v ++ creg (last args)-doOp _ op args = error "doOp of (" ++ show op ++ ") not implemented, arguments (" ++ show args ++ ")" +-- Pointer primitives (declared as %extern in Builtins.idr)+doOp v (LExternal rf) [_,x] +   | rf == sUN "prim__readFile"+       = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"+doOp v (LExternal wf) [_,x,s] +   | wf == sUN "prim__writeFile"+       = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x+                              ++ "),GETSTR("+                              ++ creg s ++ "))))"+doOp v (LExternal vm) [] | vm == sUN "prim__vm" = v ++ "MKPTR(vm, vm)"+doOp v (LExternal si) [] | si == sUN "prim__stdin" = v ++ "MKPTR(vm, stdin)"+doOp v (LExternal so) [] | so == sUN "prim__stdout" = v ++ "MKPTR(vm, stdout)"+doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"++doOp v (LExternal nul) [] | nul == sUN "prim__null" = v ++ "MKPTR(vm, NULL)"+doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"+    = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ "), GETINT(" ++ creg i ++ "))"++doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"+ flUnOp :: String -> String -> String flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))" @@ -642,7 +648,7 @@  writeIFace :: ExportIFace -> IO () writeIFace (Export ffic hdr exps)-   | ffic == sUN "FFI_C"+   | ffic == sNS (sUN "FFI_C") ["FFI_C"]        = do let hfile = "#ifndef " ++ hdr_guard hdr ++ "\n" ++                         "#define " ++ hdr_guard hdr ++ "\n\n" ++                         "#include <idris_rts.h>\n\n" ++
src/IRTS/CodegenJavaScript.hs view
@@ -47,7 +47,7 @@     lookupBigInt = any (needsBigInt . snd)       where         needsBigInt :: [BC] -> Bool-        needsBigInt bc = or $ map testBCForBigInt bc+        needsBigInt bc = any testBCForBigInt bc           where             testBCForBigInt :: BC -> Bool             testBCForBigInt (ASSIGNCONST _ c)  =@@ -55,12 +55,12 @@              testBCForBigInt (CONSTCASE _ c d) =                  maybe False needsBigInt d-              || (or $ map (needsBigInt . snd) c)-              || (or $ map (testConstForBigInt . fst) c)+              || any (needsBigInt . snd) c+              || any (testConstForBigInt . fst) c              testBCForBigInt (CASE _ _ c d) =                  maybe False needsBigInt d-              || (or $ map (needsBigInt . snd) c)+              || any (needsBigInt . snd) c              testBCForBigInt _ = False @@ -473,7 +473,6 @@ 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 0)                   = JSNum (JSInteger JSBigZero) translateConstant (BI 1)                   = JSNum (JSInteger JSBigOne)@@ -1269,7 +1268,8 @@        | LSystemInfo <- op       , (arg:_) <- args = jsCall "i$systemInfo"  [translateReg arg]-      | LNullPtr    <- op+      | LExternal nul <- op+      , nul == sUN "prim__null"       , (_)         <- args = JSNull       | otherwise = JSError $ "Not implemented: " ++ show op         where
src/IRTS/Compiler.hs view
@@ -51,8 +51,12 @@    = do checkMVs  -- check for undefined metavariables         checkTotality -- refuse to compile if there are totality problems         exports <- findExports+        let rootNames = case mtm of+                             Nothing -> []+                             Just t -> freeNames t -        reachableNames <- performUsageAnalysis (getExpNames exports)+        reachableNames <- performUsageAnalysis +                              (rootNames ++ getExpNames exports)         maindef <- case mtm of                         Nothing -> return []                         Just tm -> do md <- irMain tm@@ -185,7 +189,7 @@ build :: (Name, Def) -> Idris (Name, LDecl) build (n, d)     = do i <- getIState-         case lookup n (idris_scprims i) of+         case getPrim n i of               Just (ar, op) ->                   let args = map (\x -> sMN x "op") [0..] in                       return (n, (LFun [] n (take ar args)@@ -193,6 +197,12 @@               _ -> do def <- mkLDecl n d                       logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def                       return (n, def)+   where getPrim n i +             | Just (ar, op) <- lookup n (idris_scprims i) +                  = Just (ar, op)+             | Just ar <- lookup n (S.toList (idris_externs i))+                  = Just (ar, LExternal n)+         getPrim n i = Nothing  declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x declArgs args inl n x = LFun (if inl then [Inline] else []) n args x@@ -225,7 +235,9 @@ type Vars = M.Map Name VarInfo  irTerm :: Vars -> [Name] -> Term -> Idris LExp-irTerm vs env tm@(App f a) = case unApply tm of+irTerm vs env tm@(App _ f a) = do +  ist <- getIState+  case unApply tm of     (P _ (UN m) _, args)         | m == txt "mkForeignPrim"         -> doForeign vs env (reverse (drop 4 args)) -- drop implicits@@ -285,11 +297,13 @@      -- This case is here until we get more general inlining. It's just     -- a really common case, and the laziness hurts...-    (P _ (NS (UN be) [b,p]) _, [_,x,(App (App (App (P _ (UN d) _) _) _) t),-                                    (App (App (App (P _ (UN d') _) _) _) e)])-        | be == txt "boolElim"+    (P _ (NS (UN be) [b,p]) _, [_,x,(App _ (App _ (App _ (P _ (UN d) _) _) _) t),+                                    (App _ (App _ (App _ (P _ (UN d') _) _) _) e)])+        | be == txt "ifThenElse"         , d  == txt "Delay"         , d' == txt "Delay"+        , b  == txt "Bool"+        , p  == txt "Prelude"         -> do             x' <- irTerm vs env x             t' <- irTerm vs env t@@ -359,9 +373,12 @@     -- type constructor     (P (TCon t a) n _, args) -> return LNothing +    -- an external name applied to arguments+    (P _ n _, args) | S.member (n, length args) (idris_externs ist) -> do+        LOp (LExternal n) <$> mapM (irTerm vs env) args+     -- a name applied to arguments     (P _ n _, args) -> do-        ist <- getIState         case lookup n (idris_scprims ist) of             -- if it's a primitive that is already saturated,             -- compile to the corresponding op here already to save work
src/IRTS/Defunctionalise.hs view
@@ -162,21 +162,21 @@        | needsEval x t = DLet x (DV (Glob x)) (preEval xs t)        | otherwise = preEval xs t -    needsEval x (DApp _ _ args) = or (map (needsEval x) args)-    needsEval x (DC _ _ _ args) = or (map (needsEval x) args)-    needsEval x (DCase up e alts) = needsEval x e || or (map nec alts)+    needsEval x (DApp _ _ args) = any (needsEval x) args+    needsEval x (DC _ _ _ args) = any (needsEval x) args+    needsEval x (DCase up e alts) = needsEval x e || any nec alts       where nec (DConCase _ _ _ e) = needsEval x e             nec (DConstCase _ e) = needsEval x e             nec (DDefaultCase e) = needsEval x e-    needsEval x (DChkCase e alts) = needsEval x e || or (map nec alts)+    needsEval x (DChkCase e alts) = needsEval x e || any nec alts       where nec (DConCase _ _ _ e) = needsEval x e             nec (DConstCase _ e) = needsEval x e             nec (DDefaultCase e) = needsEval x e     needsEval x (DLet n v e)           | x == n = needsEval x v           | otherwise = needsEval x v || needsEval x e-    needsEval x (DForeign _ _ args) = or (map (needsEval x) (map snd args))-    needsEval x (DOp op args) = or (map (needsEval x) args)+    needsEval x (DForeign _ _ args) = any (needsEval x) (map snd args)+    needsEval x (DOp op args) = any (needsEval x) args     needsEval x (DProj (DV (Glob x')) _) = x == x'     needsEval x _ = False
src/IRTS/Lang.hs view
@@ -69,35 +69,21 @@             | LStrConcat | LStrLt | LStrEq | LStrLen             | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy             | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy-            | LReadStr | LWriteStr | LReadFile | LWriteFile             | LBitCast ArithTy ArithTy -- Only for values of equal width              | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan             | LFSqrt | LFFloor | LFCeil | LFNegate -           -- construction          element extraction     element insertion-            | LMkVec NativeTy Int | LIdxVec NativeTy Int | LUpdateVec NativeTy Int-             | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev-            | LStdIn | LStdOut | LStdErr+            | LReadStr | LWriteStr -            -- Buffers-            | LAllocate-            | LAppendBuffer             -- system info             | LSystemInfo-            -- 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-            | LVMPtr-            | LNullPtr-            | LRegisterPtr+            | LExternal Name             | LNoOp   deriving (Show, Eq) @@ -146,7 +132,7 @@  lname (NS n x) i = NS (lname n i) x lname (UN n) i = MN i n-lname x i = sMN i (show x)+lname x i = sMN i (show x ++ "_lam")  liftAll :: [(Name, LDecl)] -> [(Name, LDecl)] liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs
src/IRTS/System.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-} module IRTS.System(getDataFileName, getDataDir, getTargetDir,getCC,getLibFlags,getIdrisLibDir,-                   getIncFlags,getMvn,getExecutablePom, version) where+                   getIncFlags, getEnvFlags, getMvn,getExecutablePom, version) where  import Util.System+import Data.List.Split  import Control.Applicative ((<$>)) import Data.Maybe (fromMaybe)@@ -18,6 +19,12 @@  getCC :: IO String getCC = fromMaybe "gcc" <$> environment "IDRIS_CC"++getEnvFlags :: IO [String]+getEnvFlags = do flags <- environment "IDRIS_CFLAGS"+                 case flags of+                     Nothing -> return $ []+                     Just s -> return $ splitOn " " s  mvnCommand :: String #ifdef mingw32_HOST_OS
src/Idris/AbsSyntax.hs view
@@ -18,6 +18,7 @@ import System.IO  import Control.Applicative+import Control.Monad (liftM3) import Control.Monad.State  import Data.List hiding (insert,union)@@ -352,24 +353,33 @@     where ptail [] = []           ptail (x : xs) = xs --- Add a class instance function. Dodgy hack: Put integer instances first in the--- list so they are resolved by default.+-- | Add a class instance function.+--+-- Precondition: the instance should have the correct type.+--+-- Dodgy hack 1: Put integer instances first in the list so they are+-- resolved by default.+-- -- Dodgy hack 2: put constraint chasers (@@) last--addInstance :: Bool -> Name -> Name -> Idris ()-addInstance int n i+addInstance :: Bool -- ^ whether the name is an Integer instance+            -> Bool -- ^ whether to include the instance in instance search+            -> Name -- ^ the name of the class+            -> Name -- ^ the name of the instance+            -> Idris ()+addInstance int res n i     = do ist <- getIState          case lookupCtxt n (idris_classes ist) of                 [CI a b c d e ins fds] ->                      do let cs = addDef n (CI a b c d e (addI i ins) fds) (idris_classes ist)                         putIState $ ist { idris_classes = cs }-                _ -> do let cs = addDef n (CI (sMN 0 "none") [] [] [] [] [i] []) (idris_classes ist)+                _ -> do let cs = addDef n (CI (sMN 0 "none") [] [] [] [] [(i, res)] []) (idris_classes ist)                         putIState $ ist { idris_classes = cs }-  where addI i ins | int = i : ins-                   | chaser n = ins ++ [i]+  where addI, insI :: Name -> [(Name, Bool)] -> [(Name, Bool)]+        addI i ins | int = (i, res) : ins+                   | chaser n = ins ++ [(i, res)]                    | otherwise = insI i ins-        insI i [] = [i]-        insI i (n : ns) | chaser n = i : n : ns+        insI i [] = [(i, res)]+        insI i (n : ns) | chaser (fst n) = (i, res) : n : ns                         | otherwise = n : insI i ns          chaser (UN nm)@@ -385,6 +395,23 @@                       _ -> i         putIState $ ist { idris_classes = addDef n i' (idris_classes ist) } +addAutoHint :: Name -> Name -> Idris ()+addAutoHint n hint =+    do ist <- getIState+       case lookupCtxtExact n (idris_autohints ist) of+            Nothing -> +                 do let hs = addDef n [hint] (idris_autohints ist)+                    putIState $ ist { idris_autohints = hs }+            Just nhints -> +                 do let hs = addDef n (hint : nhints) (idris_autohints ist)+                    putIState $ ist { idris_autohints = hs }++getAutoHints :: Name -> Idris [Name]+getAutoHints n = do ist <- getIState+                    case lookupCtxtExact n (idris_autohints ist) of+                         Nothing -> return []+                         Just ns -> return ns+ addIBC :: IBCWrite -> Idris () addIBC ibc@(IBCDef n)            = do i <- getIState@@ -799,7 +826,9 @@  verbose :: Idris Bool verbose = do i <- getIState-             return (opt_verbose (idris_options i))+             -- Quietness overrides verbosity+             return (not (opt_quiet (idris_options i)) &&+                     opt_verbose (idris_options i))  setVerbose :: Bool -> Idris () setVerbose t = do i <- getIState@@ -932,27 +961,26 @@     mkShadow (MN i n) = MN (i+1) n     mkShadow (NS x s) = NS (mkShadow x) s -    en (PLam fc n t s)+    en (PLam fc n nfc t s)        | n `elem` (map fst ps ++ ns)                = let n' = mkShadow n in-                     PLam fc n' (en t) (en (shadow n n' s))-       | otherwise = PLam fc n (en t) (en s)-    en (PPi p n t s)+                     PLam fc n' nfc (en t) (en (shadow n n' s))+       | otherwise = PLam fc n nfc (en t) (en s)+    en (PPi p n nfc t s)        | n `elem` (map fst ps ++ ns)                = let n' = mkShadow n in -- TODO THINK SHADOWING TacImp?-                     PPi (enTacImp p) n' (en t) (en (shadow n n' s))-       | otherwise = PPi (enTacImp p) n (en t) (en s)-    en (PLet fc n ty v s)+                     PPi (enTacImp p) n' nfc (en t) (en (shadow n n' s))+       | otherwise = PPi (enTacImp p) n nfc (en t) (en s)+    en (PLet fc n nfc ty v s)        | n `elem` (map fst ps ++ ns)                = let n' = mkShadow n in-                     PLet fc n' (en ty) (en v) (en (shadow n n' s))-       | otherwise = PLet fc n (en ty) (en v) (en s)+                     PLet fc n' nfc (en ty) (en v) (en (shadow n n' s))+       | otherwise = PLet fc n nfc (en ty) (en v) (en s)     -- FIXME: Should only do this in a type signature!     en (PDPair f p (PRef f' n) t r)        | n `elem` (map fst ps ++ ns) && t /= Placeholder            = let n' = mkShadow n in                  PDPair f p (PRef f' n') (en t) (en (shadow n n' r))-    en (PEq f lt rt l r) = PEq f (en lt) (en rt) (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 p l r) = PPair f p (en l) (en r)@@ -992,7 +1020,8 @@     en (PApp fc f as) = PApp fc (en f) (map (fmap en) as)     en (PAppBind fc f as) = PAppBind fc (en f) (map (fmap en) as)     en (PCase fc c os) = PCase fc (en c) (map (pmap en) os)-    en (PRunTactics fc tm) = PRunTactics fc (en tm)+    en (PIfThenElse fc c t f) = PIfThenElse fc (en c) (en t) (en f)+    en (PRunElab fc tm) = PRunElab fc (en tm)     en t = t      nselem x [] = False@@ -1007,19 +1036,19 @@ expandParamsD :: Bool -> -- True = RHS only                  IState ->                  (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl-expandParamsD rhsonly ist dec ps ns (PTy doc argdocs syn fc o n ty)+expandParamsD rhsonly ist dec ps ns (PTy doc argdocs syn fc o n nfc ty)     = if n `elem` ns && (not rhsonly)          then -- trace (show (n, expandParams dec ps ns ty)) $-              PTy doc argdocs syn fc o (dec n) (piBindp expl_param ps (expandParams dec ps ns [] ty))+              PTy doc argdocs syn fc o (dec n) nfc (piBindp expl_param ps (expandParams dec ps ns [] ty))          else --trace (show (n, expandParams dec ps ns ty)) $-              PTy doc argdocs syn fc o n (expandParams dec ps ns [] ty)-expandParamsD rhsonly ist dec ps ns (PPostulate doc syn fc o n ty)+              PTy doc argdocs syn fc o n nfc (expandParams dec ps ns [] ty)+expandParamsD rhsonly ist dec ps ns (PPostulate e doc syn fc o n ty)     = if n `elem` ns && (not rhsonly)          then -- trace (show (n, expandParams dec ps ns ty)) $-              PPostulate doc syn fc o (dec n) (piBind ps+              PPostulate e doc syn fc o (dec n) (piBind ps                             (expandParams dec ps ns [] ty))          else --trace (show (n, expandParams dec ps ns ty)) $-              PPostulate doc syn fc o n (expandParams dec ps ns [] ty)+              PPostulate e doc syn fc o n (expandParams dec ps ns [] ty) expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)     = let n' = if n `elem` ns then dec n else n in           PClauses fc opts n' (map expandParamsC cs)@@ -1065,38 +1094,36 @@   where     -- just do the type decl, leave constructors alone (parameters will be     -- added implicitly)-    expandPData (PDatadecl n ty cons)+    expandPData (PDatadecl n nfc ty cons)        = if n `elem` ns-            then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty))+            then PDatadecl (dec n) nfc (piBind ps (expandParams dec ps ns [] ty))                            (map econ cons)-            else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)-    econ (doc, argDocs, n, t, fc, fs)-       = (doc, argDocs, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)-expandParamsD rhs ist dec ps ns (PRecord doc syn fc tn tty opts cdoc cn cty)-   = if tn `elem` ns-        then PRecord doc syn fc (dec tn) (piBind ps (expandParams dec ps ns [] tty))-                     opts cdoc (dec cn) conty-        else PRecord doc syn fc (dec tn) (expandParams dec ps ns [] tty)-                     opts cdoc (dec cn) conty-   where conty = piBindp expl ps (expandParams dec ps ns [] cty)+            else PDatadecl n nfc (expandParams dec ps ns [] ty) (map econ cons)+    econ (doc, argDocs, n, nfc, t, fc, fs)+       = (doc, argDocs, dec n, nfc, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)+expandParamsD rhs ist dec ps ns d@(PRecord doc rsyn fc opts name nfc prs pdocs fls cn cdoc csyn)+  = d 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) --                (map (expandParamsD ist dec ps ns) pds) expandParamsD rhs ist dec ps ns (PMutual f pds)    = PMutual f (map (expandParamsD rhs ist dec ps ns) pds)-expandParamsD rhs ist dec ps ns (PClass doc info f cs n params pDocs fds decls)+expandParamsD rhs ist dec ps ns (PClass doc info f cs n nfc params pDocs fds decls cn cd)    = PClass doc info f            (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs)-           n-           (map (mapsnd (expandParams dec ps ns [])) params)+           n nfc+           (map (\(n, fc, t) -> (n, fc, expandParams dec ps ns [] t)) params)            pDocs            fds            (map (expandParamsD rhs ist dec ps ns) decls)-expandParamsD rhs ist dec ps ns (PInstance doc argDocs info f cs n params ty cn decls)+           cn+           cd+expandParamsD rhs ist dec ps ns (PInstance doc argDocs info f cs n nfc params ty cn decls)    = PInstance doc argDocs info f            (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs)            n+           nfc            (map (expandParams dec ps ns []) params)            (expandParams dec ps ns [] ty)            cn@@ -1120,10 +1147,8 @@             ((P (TCon _ _) _ _):_) -> 1             ((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 (PPi _ _ _ x y) = max 5 (max (pri x) (pri y))     pri (PTrue _ _) = 0-    pri (PRefl _ _) = 1-    pri (PEq _ _ _ l r) = max 1 (max (pri l) (pri r))     pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r))     pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))     pri (PAppBind _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))@@ -1132,7 +1157,7 @@     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+    pri (PConstant _ _) = 0     pri Placeholder = 1     pri _ = 3 @@ -1166,10 +1191,10 @@        putIState $ i { idris_statics = addDef n stpos (idris_statics i) }        addIBC (IBCStatic n)   where-    initStatics (Bind n (Pi _ ty _) sc) (PPi p n' t s)-            | n /= n' = let (static, dynamic) = initStatics sc (PPi p n' t s) in+    initStatics (Bind n (Pi _ ty _) sc) (PPi p n' fc t s)+            | n /= n' = let (static, dynamic) = initStatics sc (PPi p n' fc t s) in                             (static, (n, ty) : dynamic)-    initStatics (Bind n (Pi _ ty _) sc) (PPi p n' _ s)+    initStatics (Bind n (Pi _ ty _) sc) (PPi p n' fc _ s)             = let (static, dynamic) = initStatics (instantiate (P Bound n ty) sc) s in                   if pstatic p == Static then ((n, ty) : static, dynamic)                     else if (not (searchArg p))@@ -1238,16 +1263,16 @@          -- if all of args in ns, then add it          doAdd (UConstraint c args : cs) ns t              | all (\n -> elem n ns) args-                   = PPi (Constraint [] Dynamic) (sMN 0 "cu")+                   = PPi (Constraint [] Dynamic) (sMN 0 "cu") NoFC                          (mkConst c args) (doAdd cs ns t)              | otherwise = doAdd cs ns t           mkConst c args = PApp fc (PRef fc c)                            (map (\n -> PExp 0 [] (sMN 0 "carg") (PRef fc n)) args) -         getConstraints (PPi (Constraint _ _) _ c sc)+         getConstraints (PPi (Constraint _ _) _ _ c sc)              = getcapp c ++ getConstraints sc-         getConstraints (PPi _ _ c sc) = getConstraints sc+         getConstraints (PPi _ _ _ c sc) = getConstraints sc          getConstraints _ = []           getcapp (PApp _ (PRef _ c) args)@@ -1284,7 +1309,7 @@          -- if all of args in ns, then add it          doAdd (UImplicit n ty : cs) ns t              | elem n ns-                   = PPi (Imp [] Dynamic False Nothing) n ty (doAdd cs ns t)+                   = PPi (Imp [] Dynamic False Nothing) n NoFC ty (doAdd cs ns t)              | otherwise = doAdd cs ns t           -- bind the free names which weren't in the using block@@ -1292,9 +1317,9 @@          bindFree (n:ns) tm              | elem n (map iname uimpls) = bindFree ns tm              | otherwise-                    = PPi (Imp [] Dynamic False Nothing) n Placeholder (bindFree ns tm)+                    = PPi (Imp [] Dynamic False Nothing) n NoFC Placeholder (bindFree ns tm) -         getArgnames (PPi _ n c sc)+         getArgnames (PPi _ n _ c sc)              = n : getArgnames sc          getArgnames _ = [] @@ -1303,7 +1328,7 @@  getUnboundImplicits :: IState -> Type -> PTerm -> [(Bool, PArg)] getUnboundImplicits i t tm = getImps t (collectImps tm)-  where collectImps (PPi p n t sc)+  where collectImps (PPi p n _ t sc)             = (n, (p, t)) : collectImps sc         collectImps _ = [] @@ -1403,13 +1428,13 @@        = do (decls, ns) <- get             let isn = concatMap (namesIn uvars ist) (map getTm as)             put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))-    imps top env (PPi (Imp l _ _ _) n ty sc)+    imps top env (PPi (Imp l _ _ _) n _ ty sc)         = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]              (decls , ns) <- get              put (PImp (getPriority ist ty) True l n Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc-    imps top env (PPi (Exp l _ _) n ty sc)+    imps top env (PPi (Exp l _ _) n _ ty sc)         = do let isn = nub (implNamesIn uvars ty ++ case sc of                             (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]                             _ -> [])@@ -1417,7 +1442,7 @@              put (PExp (getPriority ist ty) l n Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc-    imps top env (PPi (Constraint l _) n ty sc)+    imps top env (PPi (Constraint l _) n _ ty sc)         = do let isn = nub (implNamesIn uvars ty ++ case sc of                             (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]                             _ -> [])@@ -1425,7 +1450,7 @@              put (PConstraint 10 l n Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc-    imps top env (PPi (TacImp l _ scr) n ty sc)+    imps top env (PPi (TacImp l _ scr) n _ ty sc)         = do let isn = nub (implNamesIn uvars ty ++ case sc of                             (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]                             _ -> [])@@ -1433,10 +1458,6 @@              put (PTacImplicit 10 l n scr Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc-    imps top env (PEq _ _ _ l r)-        = do (decls, ns) <- get-             let isn = namesIn uvars ist l ++ namesIn uvars ist r-             put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))     imps top env (PRewrite _ l r _)         = do (decls, ns) <- get              let isn = namesIn uvars ist l ++ namesIn uvars ist r@@ -1460,20 +1481,20 @@         = do (decls, ns) <- get              let isn = concatMap (namesIn uvars ist) as              put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))-    imps top env (PLam fc n ty sc)+    imps top env (PLam fc n _ ty sc)         = do imps False env ty              imps False (n:env) sc     imps top env (PHidden tm)    = imps False env tm     imps top env (PUnifyLog tm)  = imps False env tm     imps top env (PNoImplicits tm)  = imps False env tm-    imps top env (PRunTactics fc tm) = imps False env tm+    imps top env (PRunElab fc tm) = imps False env tm     imps top env _               = return ()      pibind using []     sc = sc     pibind using (n:ns) sc       = case lookup n using of-            Just ty -> PPi (Imp [] Dynamic False Nothing) n ty (pibind using ns sc)-            Nothing -> PPi (Imp [] Dynamic False Nothing) n Placeholder+            Just ty -> PPi (Imp [] Dynamic False Nothing) n NoFC ty (pibind using ns sc)+            Nothing -> PPi (Imp [] Dynamic False Nothing) n NoFC Placeholder                                    (pibind using ns sc)  -- Add implicit arguments in function calls@@ -1503,15 +1524,9 @@     ai :: Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm     ai qq env ds (PRef fc f)         | f `elem` infns = PInferRef fc f-        | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat qq imp_meths ist fc f ds []+        | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat qq imp_meths ist fc f fc ds []     ai qq env ds (PHidden (PRef fc f))-        | not (f `elem` map fst env) = PHidden (handleErr $ aiFn inpat False qq imp_meths ist fc f ds [])-    ai qq env ds (PEq fc lt rt l r)-      = let lt' = ai qq env ds lt-            rt' = ai qq env ds rt-            l' = ai qq env ds l-            r' = ai qq env ds r in-            PEq fc lt' rt' l' r'+        | not (f `elem` map fst env) = PHidden (handleErr $ aiFn inpat False qq imp_meths ist fc f fc ds [])     ai qq env ds (PRewrite fc l r g)        = let l' = ai qq env ds l              r' = ai qq env ds r@@ -1534,14 +1549,14 @@            = let as' = map (ai qq env ds) as in                  PAlternative a as'     ai qq env _ (PDisamb ds' as) = ai qq env ds' as-    ai qq env ds (PApp fc (PInferRef _ f) as)+    ai qq env ds (PApp fc (PInferRef ffc f) as)         = let as' = map (fmap (ai qq env ds)) as in-              PApp fc (PInferRef fc f) as'-    ai qq env ds (PApp fc ftm@(PRef _ f) as)-        | f `elem` infns = ai qq env ds (PApp fc (PInferRef fc f) as)+              PApp fc (PInferRef ffc f) as'+    ai qq env ds (PApp fc ftm@(PRef ffc f) as)+        | f `elem` infns = ai qq env ds (PApp fc (PInferRef ffc f) as)         | not (f `elem` map fst env)                           = let as' = map (fmap (ai qq env ds)) as in-                                handleErr $ aiFn inpat False qq imp_meths ist fc f ds as'+                                handleErr $ aiFn inpat False qq imp_meths ist fc f ffc ds as'         | Just (Just ty) <- lookup f env =              let as' = map (fmap (ai qq env ds)) as                  arity = getPArity ty in@@ -1556,30 +1571,35 @@         -- definition which is passed through addImpl again with more scope         -- information             PCase fc c' os++    ai qq env ds (PIfThenElse fc c t f) = PIfThenElse fc (ai qq env ds c)+                                                         (ai qq env ds t)+                                                         (ai qq env ds f)+     -- If the name in a lambda is a constructor name, do this as a 'case'     -- instead (it is harmless to do so, especially since the lambda will     -- be lifted anyway!)-    ai qq env ds (PLam fc n ty sc)+    ai qq env ds (PLam fc n nfc ty sc)       = case lookupDef n (tt_ctxt ist) of              [] -> let ty' = ai qq env ds ty                        sc' = ai qq ((n, Just ty):env) ds sc in-                       PLam fc n ty' sc'-             _ -> ai qq env ds (PLam fc (sMN 0 "lamp") ty+                       PLam fc n nfc ty' sc'+             _ -> ai qq env ds (PLam fc (sMN 0 "lamp") NoFC ty                                      (PCase fc (PRef fc (sMN 0 "lamp") )                                         [(PRef fc n, sc)]))-    ai qq env ds (PLet fc n ty val sc)+    ai qq env ds (PLet fc n nfc ty val sc)       = case lookupDef n (tt_ctxt ist) of              [] -> let ty' = ai qq env ds ty                        val' = ai qq env ds val                        sc' = ai qq ((n, Just ty):env) ds sc in-                       PLet fc n ty' val' sc'+                       PLet fc n nfc ty' val' sc'              _ -> ai qq env ds (PCase fc val [(PRef fc n, sc)])-    ai qq env ds (PPi p n ty sc)+    ai qq env ds (PPi p n nfc ty sc)       = let ty' = ai qq env ds ty             env' = if n `elem` imp_meths then env                       else ((n, Just ty) : env)             sc' = ai qq env' ds sc in-            PPi p n ty' sc'+            PPi p n nfc ty' sc'     ai qq env ds (PGoal fc r n sc)       = let r' = ai qq env ds r             sc' = ai qq ((n, Nothing):env) ds sc in@@ -1587,13 +1607,12 @@     ai qq env ds (PHidden tm) = PHidden (ai qq env ds tm)     -- Don't do PProof or PTactics since implicits get added when scope is     -- properly known in ElabTerm.runTac-    ai qq env ds (PRefl fc tm) = PRefl fc (ai qq env ds tm)     ai qq env ds (PUnifyLog tm) = PUnifyLog (ai qq env ds tm)     ai qq env ds (PNoImplicits tm) = PNoImplicits (ai qq env ds tm)     ai qq env ds (PQuasiquote tm g) = PQuasiquote (ai True env ds tm)                                                   (fmap (ai True env ds) g)     ai qq env ds (PUnquote tm) = PUnquote (ai False env ds tm)-    ai qq env ds (PRunTactics fc tm) = PRunTactics fc (ai False env ds tm)+    ai qq env ds (PRunElab fc tm) = PRunElab fc (ai False env ds tm)     ai qq env ds tm = tm      handleErr (Left err) = PElabError err@@ -1602,17 +1621,17 @@ -- 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 -> Bool -> [Name] -> IState -> FC -> Name -> [[T.Text]] -> [PArg] -> Either Err PTerm-aiFn inpat True qq imp_meths ist fc f ds []+aiFn :: Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -> FC -> [[T.Text]] -> [PArg] -> Either Err PTerm+aiFn inpat True qq imp_meths ist fc f ffc ds []   = case lookupDef f (tt_ctxt ist) of-        [] -> Right $ PPatvar fc f+        [] -> Right $ PPatvar ffc f         alts -> let ialts = lookupCtxtName f (idris_implicits ist) in                     -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $                     if (not (vname f) || tcname f                            || any (conCaf (tt_ctxt ist)) ialts) --                            any constructor alts || any allImp ialts))-                        then aiFn inpat False qq imp_meths ist fc f ds [] -- use it as a constructor-                        else Right $ PPatvar fc f+                        then aiFn inpat False qq imp_meths ist fc f ffc ds [] -- use it as a constructor+                        else Right $ PPatvar ffc f     where imp (PExp _ _ _ _) = False           imp _ = True --           allImp [] = False@@ -1625,9 +1644,9 @@           vname (UN n) = True -- non qualified           vname _ = False -aiFn inpat expat qq imp_meths ist fc f ds as-    | f `elem` primNames = Right $ PApp fc (PRef fc f) as-aiFn inpat expat qq imp_meths ist fc f ds as+aiFn inpat expat qq imp_meths ist fc f ffc ds as+    | f `elem` primNames = Right $ PApp fc (PRef ffc f) as+aiFn inpat expat qq imp_meths ist fc f ffc ds as           -- This is where namespaces get resolved by adding PAlternative      = do let ns = lookupCtxtName f (idris_implicits ist)           let nh = filter (\(n, _) -> notHidden n) ns@@ -1635,13 +1654,13 @@                          [] -> nh                          x -> x           case ns' of-            [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc (isImpName f f')) (insertImpl ns as)+            [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc (isImpName f 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+                    then Right $ PApp fc (PRef ffc f) as+                    else Right $ mkPApp fc (length as) (PRef ffc f) as             alts -> Right $-                         PAlternative True $-                           map (\(f', ns) -> mkPApp fc (length ns) (PRef fc (isImpName f f'))+                         PAlternative (ExactlyOne True) $+                           map (\(f', ns) -> mkPApp fc (length ns) (PRef ffc (isImpName f f'))                                                   (insertImpl ns as)) alts   where     -- if the name is in imp_meths, we should actually refer to the bound@@ -1666,7 +1685,7 @@                     _ -> Public      insertImpl :: [PArg] -> [PArg] -> [PArg]-    insertImpl ps as = insImpAcc M.empty ps (filter exp as) (filter (not.exp) as)+    insertImpl ps as = insImpAcc M.empty ps (filter exp as) (filter (not . exp) as)      exp (PExp _ _ _ _) = True     exp (PConstraint _ _ _ _) = True@@ -1749,9 +1768,12 @@                                 t' <- sl t                                 r' <- sl r                                 return (PDPair fc p l' t' r')-    sl (PApp fc fn args) = do -- Just the args, fn isn't matchable as a var+    sl (PApp fc fn args) = do fn' <- case fn of+                                     -- Just the args, fn isn't matchable as a var+                                          PRef _ _ -> return fn+                                          t -> sl t                               args' <- mapM slA args-                              return $ PApp fc fn args'+                              return $ PApp fc fn' args'        where slA (PImp p m l n t) = do t' <- sl t                                        return $ PImp p m l n t'              slA (PExp p l n t) = do  t' <- sl t@@ -1764,10 +1786,9 @@                                      return $ PTacImplicit p l n sc t'     sl x = return x --- Remove functions which aren't applied to anything, which must then+-- | Remove functions which aren't applied to anything, which must then -- be resolved by unification. Assume names resolved and alternatives -- filled in (so no ambiguity).- stripUnmatchable :: IState -> PTerm -> PTerm stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where     su :: PTerm -> PTerm@@ -1789,9 +1810,8 @@                            else PAlternative b alts'     su (PPair fc p l r) = PPair fc p (su l) (su r)     su (PDPair fc p l t r) = PDPair fc p (su l) (su t) (su r)-    su t@(PLam fc _ _ _) = PHidden t-    su t@(PPi _ _ _ _) = PHidden t-    su t@(PEq _ _ _ _ _) = PHidden t+    su t@(PLam fc _ _ _ _) = PHidden t+    su t@(PPi _ _ _ _ _) = PHidden t     su t = t      ctxt = tt_ctxt i@@ -1814,7 +1834,7 @@ findStatics ist tm = trace (show tm) $                       let (ns, ss) = fs tm in                          runState (pos ns ss tm) []-  where fs (PPi p n t sc)+  where fs (PPi p n fc t sc)             | Static <- pstatic p                         = let (ns, ss) = fs sc in                               (namesIn [] ist t : ns, n : ss)@@ -1824,15 +1844,15 @@          inOne n ns = length (filter id (map (elem n) ns)) == 1 -        pos ns ss (PPi p n t sc)+        pos ns ss (PPi p n fc t sc)             | elem n ss = do sc' <- pos ns ss sc                              spos <- get                              put (True : spos)-                             return (PPi (p { pstatic = Static }) n t sc')+                             return (PPi (p { pstatic = Static }) n fc t sc')             | otherwise = do sc' <- pos ns ss sc                              spos <- get                              put (False : spos)-                             return (PPi p n t sc')+                             return (PPi p n fc t sc')         pos ns ss t = return t  -- for 6.12/7 compatibility@@ -1851,9 +1871,8 @@ toEither (LeftErr e)  = Left e toEither (RightOK ho) = Right ho --- syntactic match of a against b, returning pair of variables in a+-- | Syntactic match of a against b, returning pair of variables in a -- and what they match. Returns the pair that failed if not a match.- matchClause :: IState -> PTerm -> PTerm -> Either (PTerm, PTerm) [(Name, PTerm)] matchClause = matchClause' False @@ -1867,10 +1886,10 @@     match' x y = match (fullApp x) (fullApp y)     match (PApp _ (PRef _ (NS (UN fi) [b])) [_,_,x]) x'         | fi == txt "fromInteger" && b == txt "builtins",-          PConstant (I _) <- getTm x = match (getTm x) x'+          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'+          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')@@ -1895,10 +1914,6 @@         | not names && (not (isConName n (tt_ctxt i) ||                              isFnName n (tt_ctxt i)) || tm == Placeholder)             = return [(n, tm)]-    match (PEq _ _ _ l r) (PEq _ _ _ l' r')-                                    = do ml <- match' l l'-                                         mr <- match' r r'-                                         return (ml ++ mr)     match (PRewrite _ l r _) (PRewrite _ l' r' _)                                     = do ml <- match' l l'                                          mr <- match' r r'@@ -1924,25 +1939,24 @@                 (x: _) -> return x                 _ -> LeftErr (a, b)     match (PCase _ _ _) _ = return [] -- lifted out-    match (PMetavar _) _ = return [] -- modified+    match (PMetavar _ _) _ = return [] -- modified     match (PInferRef _ _) _ = return [] -- modified     match (PQuote _) _ = return []     match (PProof _) _ = return []     match (PTactics _) _ = return []-    match (PRefl _ _) (PRefl _ _) = return []     match (PResolveTC _) (PResolveTC _) = return []     match (PTrue _ _) (PTrue _ _) = return []     match (PReturn _) (PReturn _) = return []-    match (PPi _ _ t s) (PPi _ _ t' s') = do mt <- match' t t'-                                             ms <- match' s s'-                                             return (mt ++ ms)-    match (PLam _ _ t s) (PLam _ _ t' s') = do mt <- match' t t'-                                               ms <- match' s s'-                                               return (mt ++ ms)-    match (PLet _ _ t ty s) (PLet _ _ t' ty' s') = do mt <- match' t t'-                                                      mty <- match' ty ty'-                                                      ms <- match' s s'-                                                      return (mt ++ mty ++ ms)+    match (PPi _ _ _ t s) (PPi _ _ _ t' s') = do mt <- match' t t'+                                                 ms <- match' s s'+                                                 return (mt ++ ms)+    match (PLam _ _ _ t s) (PLam _ _ _ t' s') = do mt <- match' t t'+                                                   ms <- match' s s'+                                                   return (mt ++ ms)+    match (PLet _ _ _ t ty s) (PLet _ _ _ t' ty' s') = do mt <- match' t t'+                                                          mty <- match' ty ty'+                                                          ms <- match' s s'+                                                          return (mt ++ mty ++ ms)     match (PHidden x) (PHidden y)           | RightOK xs <- match x y = return xs -- to collect variables           | otherwise = return [] -- Otherwise hidden things are unmatchable@@ -1985,16 +1999,16 @@ substMatchShadow :: Name -> [Name] -> PTerm -> PTerm -> PTerm substMatchShadow n shs tm t = sm shs t where     sm xs (PRef _ n') | n == n' = tm-    sm xs (PLam fc x t sc) = PLam fc x (sm xs t) (sm xs sc)-    sm xs (PPi p x t sc)+    sm xs (PLam fc x xfc t sc) = PLam fc x xfc (sm xs t) (sm xs sc)+    sm xs (PPi p x fc t sc)          | x `elem` xs              = let x' = nextName x in-                   PPi p x' (sm (x':xs) (substMatch x (PRef emptyFC x') t))-                            (sm (x':xs) (substMatch x (PRef emptyFC x') sc))-         | otherwise = PPi p x (sm xs t) (sm (x : xs) sc)+                   PPi p x' fc (sm (x':xs) (substMatch x (PRef emptyFC x') t))+                               (sm (x':xs) (substMatch x (PRef emptyFC x') sc))+         | otherwise = PPi p x fc (sm xs t) (sm (x : xs) sc)     sm xs (PApp f x as) = fullApp $ PApp f (sm xs x) (map (fmap (sm xs)) as)     sm xs (PCase f x as) = PCase f (sm xs x) (map (pmap (sm xs)) as)-    sm xs (PEq f xt yt x y) = PEq f (sm xs xt) (sm xs yt) (sm xs x) (sm xs y)+    sm xs (PIfThenElse fc c t f) = PIfThenElse fc (sm xs c) (sm xs t) (sm xs f)     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)@@ -2004,6 +2018,7 @@     sm xs (PHidden x) = PHidden (sm xs x)     sm xs (PUnifyLog x) = PUnifyLog (sm xs x)     sm xs (PNoImplicits x) = PNoImplicits (sm xs x)+    sm xs (PRunElab fc script) = PRunElab fc (sm xs script)     sm xs x = x      fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs))@@ -2012,16 +2027,16 @@ shadow :: Name -> Name -> PTerm -> PTerm shadow n n' t = sm t where     sm (PRef fc x) | n == x = PRef fc n'-    sm (PLam fc x t sc) | n /= x = PLam fc x (sm t) (sm sc)-                        | otherwise = PLam fc x (sm t) sc-    sm (PPi p x t sc) | n /= x = PPi p x (sm t) (sm sc)-                      | otherwise = PPi p x (sm t) sc-    sm (PLet fc x t v sc) | n /= x = PLet fc x (sm t) (sm v) (sm sc)-                          | otherwise = PLet fc x (sm t) (sm v) sc+    sm (PLam fc x xfc t sc) | n /= x = PLam fc x xfc (sm t) (sm sc)+                            | otherwise = PLam fc x xfc (sm t) sc+    sm (PPi p x fc t sc) | n /= x = PPi p x fc (sm t) (sm sc)+                         | otherwise = PPi p x fc (sm t) sc+    sm (PLet fc x xfc t v sc) | n /= x = PLet fc x xfc (sm t) (sm v) (sm sc)+                              | otherwise = PLet fc x xfc (sm t) (sm v) 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 xt yt x y) = PEq f (sm xt) (sm yt) (sm x) (sm y)+    sm (PIfThenElse fc c t f) = PIfThenElse fc (sm c) (sm t) (sm f)     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 p x y) = PPair f p (sm x) (sm y)@@ -2056,7 +2071,7 @@   mkUniqT tac = return tac    mkUniq :: PTerm -> State (S.Set Name) PTerm-  mkUniq (PLam fc n ty sc)+  mkUniq (PLam fc n nfc ty sc)          = do env <- get               (n', sc') <-                     if n `S.member` env@@ -2067,8 +2082,8 @@               put (S.insert n' env)               ty' <- mkUniq ty               sc'' <- mkUniq sc'-              return $! PLam fc n' ty' sc''-  mkUniq (PPi p n ty sc)+              return $! PLam fc n' nfc ty' sc''+  mkUniq (PPi p n fc ty sc)          = do env <- get               (n', sc') <-                     if n `S.member` env@@ -2079,8 +2094,8 @@               put (S.insert n' env)               ty' <- mkUniq ty               sc'' <- mkUniq sc'-              return $! PPi p n' ty' sc''-  mkUniq (PLet fc n ty val sc)+              return $! PPi p n' fc ty' sc''+  mkUniq (PLet fc n nfc ty val sc)          = do env <- get               (n', sc') <-                     if n `S.member` env@@ -2091,7 +2106,7 @@               put (S.insert n' env)               ty' <- mkUniq ty; val' <- mkUniq val               sc'' <- mkUniq sc'-              return $! PLet fc n' ty' val' sc''+              return $! PLet fc n' nfc ty' val' sc''   mkUniq (PApp fc t args)          = do t' <- mkUniq t               args' <- mapM mkUniqA args@@ -2105,6 +2120,8 @@               alts' <- mapM (\(x,y)-> do x' <- mkUniq x; y' <- mkUniq y                                          return (x', y')) alts               return $! PCase fc t' alts'+  mkUniq (PIfThenElse fc c t f)+         = liftM3 (PIfThenElse fc) (mkUniq c) (mkUniq t) (mkUniq f)   mkUniq (PPair fc p l r)          = do l' <- mkUniq l; r' <- mkUniq r               return $! PPair fc p l' r'@@ -2130,5 +2147,5 @@   mkUniq (PNoImplicits t) = liftM PNoImplicits (mkUniq t)   mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts)   mkUniq (PTactics ts) = liftM PTactics (mapM mkUniqT ts)-  mkUniq (PRunTactics fc ts) = liftM (PRunTactics fc ) (mkUniq ts)+  mkUniq (PRunElab fc ts) = liftM (PRunElab fc ) (mkUniq ts)   mkUniq t = return t
src/Idris/AbsSyntaxTree.hs view
@@ -18,6 +18,8 @@ import System.Console.Haskeline import System.IO +import Prelude hiding ((<$>))+ import Control.Applicative ((<|>))  import Control.Monad.Trans.State.Strict@@ -34,7 +36,7 @@ import Data.Either import qualified Data.Set as S import Data.Word (Word)-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.Traversable (Traversable) import Data.Typeable import Data.Foldable (Foldable)@@ -179,6 +181,7 @@     idris_tyinfodata :: Ctxt TIData,     idris_fninfo :: Ctxt FnInfo,     idris_transforms :: Ctxt [(Term, Term)],+    idris_autohints :: Ctxt [Name],     idris_totcheck :: [(FC, Name)], -- names to check totality on     idris_defertotcheck :: [(FC, Name)], -- names to check at the end     idris_totcheckfail :: [(FC, String)],@@ -226,6 +229,7 @@     module_aliases :: M.Map [T.Text] [T.Text],     idris_consolewidth :: ConsoleWidth, -- ^ How many chars wide is the console?     idris_postulates :: S.Set Name,+    idris_externs :: S.Set (Name, Int),     idris_erasureUsed :: [(Name, Int)], -- ^ Function/constructor name, argument position is used     idris_whocalls :: Maybe (M.Map Name [Name]),     idris_callswho :: Maybe (M.Map Name [Name]),@@ -270,7 +274,7 @@               | IBCImp Name               | IBCStatic Name               | IBCClass Name-              | IBCInstance Bool Name Name+              | IBCInstance Bool Bool Name Name               | IBCDSL Name               | IBCData Name               | IBCOpt Name@@ -300,11 +304,13 @@               | IBCErrorHandler Name               | IBCFunctionErrorHandler Name Name Name               | IBCPostulate Name+              | IBCExtern (Name, Int)               | IBCTotCheckErr FC String               | IBCParsedRegion FC               | IBCModDocs Name -- ^ The name is the special name used to track module docs               | IBCUsage (Name, Int)               | IBCExport Name+              | IBCAutoHint Name Name   deriving Show  -- | The initial state for the compiler@@ -314,10 +320,11 @@                    emptyContext emptyContext emptyContext emptyContext                    emptyContext emptyContext emptyContext emptyContext                    emptyContext emptyContext emptyContext emptyContext+                   emptyContext                    [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] []                    [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] []                    (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty-                   AutomaticWidth S.empty [] Nothing Nothing [] [] M.empty []+                   AutomaticWidth S.empty S.empty [] Nothing Nothing [] [] M.empty []  -- | The monad for the main REPL - reading and processing files and updating -- global state (hence the IO inner monad).@@ -362,7 +369,7 @@              | ModImport String              | Edit              | Compile Codegen String-             | Execute+             | Execute PTerm              | ExecVal PTerm              | Metavars              | Prove Name@@ -401,6 +408,7 @@              | Apropos [String] String              | WhoCalls Name              | CallsWho Name+             | Browse [String]              | MakeDoc String                      -- IdrisDoc              | Warranty              | PrintDef Name@@ -558,6 +566,7 @@            | Reflection -- a reflecting function, compile-time only            | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names            | Constructor -- Data constructor type+           | AutoHint -- use in auto implicit search     deriving (Show, Eq) {-! deriving instance Binary FnOpt@@ -573,15 +582,6 @@ dictionary = elem Dictionary  --- | 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-             | DefaultCaseFun -- ^ Set if a case function should be generated for data type-             | DataErrRev-    deriving (Show, Eq)--type DataOpts = [DataOpt]- -- | Type provider - what to provide data ProvideWhat' t = ProvTerm t t     -- ^ the first is the goal type, the second is the term                     | ProvPostulate t  -- ^ goal type must be Type, so only term@@ -593,29 +593,45 @@ -- datatypes and typeclasses. data PDecl' t    = PFix     FC Fixity [String] -- ^ Fixity declaration-   | PTy      (Docstring (Either Err PTerm)) [(Name, Docstring (Either Err PTerm))] SyntaxInfo FC FnOpts Name t   -- ^ Type declaration-   | PPostulate (Docstring (Either Err PTerm)) SyntaxInfo FC FnOpts Name t -- ^ Postulate+   | PTy      (Docstring (Either Err PTerm)) [(Name, Docstring (Either Err PTerm))] SyntaxInfo FC FnOpts Name FC t   -- ^ Type declaration (last FC is precise name location)+   | PPostulate Bool -- external def if true+          (Docstring (Either Err PTerm)) SyntaxInfo FC FnOpts Name t -- ^ Postulate    | PClauses FC FnOpts Name [PClause' t]   -- ^ Pattern clause    | PCAF     FC Name t -- ^ Top level constant    | PData    (Docstring (Either Err PTerm)) [(Name, Docstring (Either Err PTerm))] SyntaxInfo FC DataOpts (PData' t)  -- ^ Data declaration.    | PParams  FC [(Name, t)] [PDecl' t] -- ^ Params block-   | PNamespace String [PDecl' t] -- ^ New namespace-   | PRecord  (Docstring (Either Err PTerm)) SyntaxInfo FC Name t DataOpts (Docstring (Either Err PTerm)) Name t  -- ^ Record declaration+   | PNamespace String FC [PDecl' t]+     -- ^ New namespace, where FC is accurate location of the+     -- namespace in the file+   | PRecord  (Docstring (Either Err PTerm)) SyntaxInfo FC DataOpts+              Name                 -- Record name+              FC                   -- Record name precise location+              [(Name, FC, Plicity, t)] -- Parameters, where FC is precise name span+              [(Name, Docstring (Either Err PTerm))] -- Param Docs+              [((Maybe (Name, FC)), Plicity, t, Maybe (Docstring (Either Err PTerm)))] -- Fields+              (Maybe (Name, FC)) -- Optional constructor name and location+              (Docstring (Either Err PTerm)) -- Constructor doc+              SyntaxInfo -- Constructor SyntaxInfo+              -- ^ Record declaration    | PClass   (Docstring (Either Err PTerm)) SyntaxInfo FC               [(Name, t)] -- constraints-              Name-              [(Name, t)] -- parameters+              Name -- class name+              FC -- accurate location of class name+              [(Name, FC, t)] -- parameters and precise locations               [(Name, Docstring (Either Err PTerm))] -- parameter docstrings-              [Name] -- determining parameters+              [(Name, FC)] -- determining parameters and precise locations               [PDecl' t] -- declarations+              (Maybe (Name, FC)) -- instance constructor name and location+              (Docstring (Either Err PTerm)) -- instance constructor docs               -- ^ Type class: arguments are documentation, syntax info, source location, constraints,-              -- class name, parameters, method declarations+              -- class name, class name location, parameters, method declarations, optional constructor name    | PInstance        (Docstring (Either Err PTerm)) -- Instance docs        [(Name, Docstring (Either Err PTerm))] -- Parameter docs        SyntaxInfo        FC [(Name, t)] -- constraints        Name -- class+       FC -- precise location of class        [t] -- parameters        t -- full instance type        (Maybe Name) -- explicit name@@ -626,7 +642,7 @@    | PDSL     Name (DSL' t) -- ^ DSL declaration    | PSyntax  FC Syntax -- ^ Syntax definition    | PMutual  FC [PDecl' t] -- ^ Mutual block-   | PDirective (Idris ()) -- ^ Compiler directive. The parser inserts the corresponding action in the Idris monad.+   | PDirective Directive -- ^ Compiler directive.    | PProvider (Docstring (Either Err PTerm)) SyntaxInfo FC (ProvideWhat' t) Name -- ^ Type provider. The first t is the type, the second is the term    | PTransform FC Bool t t -- ^ Source-to-source transformation rule. If                             -- bool is True, lhs and rhs must be convertible@@ -636,18 +652,45 @@ deriving instance NFData PDecl' !-} --- For elaborator state+-- | The set of source directives+data Directive = DLib Codegen String |+                 DLink Codegen String |+                 DFlag Codegen String |+                 DInclude Codegen String |+                 DHide Name |+                 DFreeze Name |+                 DAccess Accessibility |+                 DDefault Bool |+                 DLogging Integer |+                 DDynamicLibs [String] |+                 DNameHint Name [Name] |+                 DErrorHandlers Name Name [Name] |+                 DLanguage LanguageExt |+                 DUsed FC Name Name++-- | A set of instructions for things that need to happen in IState+-- after a term elaboration when there's been reflected elaboration.+data RDeclInstructions = RTyDeclInstrs Name FC [PArg] Type+                       | RClausesInstrs Name [([Name], Term, Term)]+                       | RAddInstance Name Name++-- | For elaborator state data EState = EState {-                  case_decls :: [PDecl],-                  delayed_elab :: [Elab' EState ()],-                  new_tyDecls :: [(Name, FC, [PArg], Type)]+                  case_decls :: [(Name, PDecl)],+                  delayed_elab :: [(Int, Elab' EState ())],+                  new_tyDecls :: [RDeclInstructions],+                  highlighting :: [(FC, OutputAnnotation)]               }  initEState :: EState-initEState = EState [] [] []+initEState = EState [] [] [] []  type ElabD a = Elab' EState a +highlightSource :: FC -> OutputAnnotation -> ElabD ()+highlightSource fc annot =+  updateAux (\aux -> aux { highlighting = (fc, annot) : highlighting aux })+ -- | One clause of a top-level definition. Term arguments to constructors are: -- -- 1. The whole application (missing for PClauseR and PWithR because they're within a "with" clause)@@ -658,10 +701,10 @@ -- -- 4. The where block (PDecl' t) -data PClause' t = PClause  FC Name t [t] t              [PDecl' t] -- ^ A normal top-level definition.-                | PWith    FC Name t [t] t (Maybe Name) [PDecl' t]-                | PClauseR FC        [t] t              [PDecl' t]-                | PWithR   FC        [t] t (Maybe Name) [PDecl' t]+data PClause' t = PClause  FC Name t [t] t                    [PDecl' t] -- ^ A normal top-level definition.+                | PWith    FC Name t [t] t (Maybe (Name, FC)) [PDecl' t]+                | PClauseR FC        [t] t                    [PDecl' t]+                | PWithR   FC        [t] t (Maybe (Name, FC)) [PDecl' t]     deriving Functor {-! deriving instance Binary PClause'@@ -670,11 +713,12 @@  -- | Data declaration data PData' t  = PDatadecl { d_name :: Name, -- ^ The name of the datatype+                             d_name_fc :: FC, -- ^ The precise location of the type constructor name                              d_tcon :: t, -- ^ Type constructor-                             d_cons :: [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, t, FC, [Name])] -- ^ Constructors+                             d_cons :: [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, t, FC, [Name])] -- ^ Constructors                            }                  -- ^ Data declaration-               | PLaterdecl { d_name :: Name, d_tcon :: t }+               | PLaterdecl { d_name :: Name, d_name_fc :: FC, d_tcon :: t }                  -- ^ "Placeholder" for data whose constructors are defined later     deriving Functor {-!@@ -693,58 +737,59 @@  declared :: PDecl -> [Name] declared (PFix _ _ _) = []-declared (PTy _ _ _ _ _ n t) = [n]-declared (PPostulate _ _ _ _ n t) = [n]+declared (PTy _ _ _ _ _ n fc t) = [n]+declared (PPostulate _ _ _ _ _ n t) = [n] declared (PClauses _ _ n _) = [] -- not a declaration declared (PCAF _ n _) = [n]-declared (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts-   where fstt (_, _, a, _, _, _) = a-declared (PData _ _ _ _ _ (PLaterdecl n _)) = [n]+declared (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts+   where fstt (_, _, a, _, _, _, _) = a+declared (PData _ _ _ _ _ (PLaterdecl n _ _)) = [n] declared (PParams _ _ ds) = concatMap declared ds-declared (PNamespace _ ds) = concatMap declared ds-declared (PRecord _ _ _ n _ _ _ c _) = [n, c]-declared (PClass _ _ _ _ n _ _ _ ms) = n : concatMap declared ms-declared (PInstance _ _ _ _ _ _ _ _ _ _) = []+declared (PNamespace _ _ ds) = concatMap declared ds+declared (PRecord _ _ _ _ n  _ _ _ _ cn _ _) = n : map fst (maybeToList cn)+declared (PClass _ _ _ _ n _ _ _ _ ms cn cd) = n : (map fst (maybeToList cn) ++ concatMap declared ms)+declared (PInstance _ _ _ _ _ _ _ _ _ _ _) = [] declared (PDSL n _) = [n] declared (PSyntax _ _) = [] declared (PMutual _ ds) = concatMap declared ds declared (PDirective _) = []+declared _ = []  -- get the names declared, not counting nested parameter blocks tldeclared :: PDecl -> [Name] tldeclared (PFix _ _ _) = []-tldeclared (PTy _ _ _ _ _ n t) = [n]-tldeclared (PPostulate _ _ _ _ n t) = [n]+tldeclared (PTy _ _ _ _ _ n _ t) = [n]+tldeclared (PPostulate _ _ _ _ _ n t) = [n] 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+tldeclared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)+tldeclared (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts+   where fstt (_, _, a, _, _, _, _) = a tldeclared (PParams _ _ ds) = [] tldeclared (PMutual _ ds) = concatMap tldeclared ds-tldeclared (PNamespace _ ds) = concatMap tldeclared ds-tldeclared (PClass _ _ _ _ n _ _ _ ms) = concatMap tldeclared ms-tldeclared (PInstance _ _ _ _ _ _ _ _ _ _) = []+tldeclared (PNamespace _ _ ds) = concatMap tldeclared ds+tldeclared (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap tldeclared ms)+tldeclared (PInstance _ _ _ _ _ _ _ _ _ _ _) = [] tldeclared _ = []  defined :: PDecl -> [Name] defined (PFix _ _ _) = []-defined (PTy _ _ _ _ _ n t) = []-defined (PPostulate _ _ _ _ n t) = []+defined (PTy _ _ _ _ _ n _ t) = []+defined (PPostulate _ _ _ _ _ n t) = [] defined (PClauses _ _ n _) = [n] -- not a declaration defined (PCAF _ n _) = [n]-defined (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts-   where fstt (_, _, a, _, _, _) = a-defined (PData _ _ _ _ _ (PLaterdecl n _)) = []+defined (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts+   where fstt (_, _, a, _, _, _, _) = a+defined (PData _ _ _ _ _ (PLaterdecl n _ _)) = [] defined (PParams _ _ ds) = concatMap defined ds-defined (PNamespace _ ds) = concatMap defined ds-defined (PRecord _ _ _ n _ _ _ c _) = [n, c]-defined (PClass _ _ _ _ n _ _ _ ms) = n : concatMap defined ms-defined (PInstance _ _ _ _ _ _ _ _ _ _) = []+defined (PNamespace _ _ ds) = concatMap defined ds+defined (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)+defined (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap defined ms)+defined (PInstance _ _ _ _ _ _ _ _ _ _ _) = [] defined (PDSL n _) = [n] defined (PSyntax _ _) = [] defined (PMutual _ ds) = concatMap defined ds defined (PDirective _) = []---defined _ = []+defined _ = []  updateN :: [(Name, Name)] -> Name -> Name updateN ns n | Just n' <- lookup n ns = n'@@ -774,34 +819,33 @@            | PRef FC Name -- ^ A reference to a variable            | PInferRef FC Name -- ^ A name to be defined later            | PPatvar FC Name -- ^ A pattern variable-           | PLam FC Name PTerm PTerm -- ^ A lambda abstraction-           | PPi  Plicity Name PTerm PTerm -- ^ (n : t1) -> t2-           | PLet FC Name PTerm PTerm PTerm -- ^ A let binding+           | PLam FC Name FC PTerm PTerm -- ^ A lambda abstraction. Second FC is name span.+           | PPi  Plicity Name FC PTerm PTerm -- ^ (n : t1) -> t2, where the FC is for the precise location of the variable+           | PLet FC Name FC PTerm PTerm PTerm -- ^ A let binding (second FC is precise name location)            | PTyped PTerm PTerm -- ^ Term with explicit type            | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x            | PAppImpl PTerm [ImplicitInfo] -- ^ Implicit argument application (introduced during elaboration only)            | PAppBind FC PTerm [PArg] -- ^ implicitly bound application            | PMatchApp FC Name -- ^ Make an application by type matching+           | PIfThenElse FC PTerm PTerm PTerm -- ^ Conditional expressions - elaborated to an overloading of ifThenElse            | PCase FC PTerm [(PTerm, PTerm)] -- ^ A case expression. Args are source location, scrutinee, and a list of pattern/RHS pairs            | PTrue FC PunInfo -- ^ Unit type..?-           | PRefl FC PTerm -- ^ The canonical proof of the equality type            | PResolveTC FC -- ^ Solve this dictionary by type class resolution-           | PEq FC PTerm PTerm PTerm PTerm -- ^ Heterogeneous equality type: A = B            | PRewrite FC PTerm PTerm (Maybe PTerm) -- ^ "rewrite" syntax, with optional result type            | PPair FC PunInfo PTerm PTerm -- ^ A pair (a, b) and whether it's a product type or a pair (solved by elaboration)            | PDPair FC PunInfo PTerm PTerm PTerm -- ^ A dependent pair (tm : a ** b) and whether it's a sigma type or a pair that inhabits one (solved by elaboration)            | PAs FC Name PTerm -- ^ @-pattern, valid LHS only-           | PAlternative Bool [PTerm] -- ^ True if only one may work. (| A, B, C|)+           | PAlternative PAltType [PTerm] -- ^ True if only one may work. (| A, B, C|)            | PHidden PTerm -- ^ Irrelevant or hidden pattern-           | PType -- ^ 'Type' type+           | PType FC -- ^ 'Type' type            | PUniverse Universe -- ^ Some universe            | PGoal FC PTerm Name PTerm -- ^ quoteGoal, used for %reflection functions-           | PConstant Const -- ^ Builtin types+           | PConstant FC Const -- ^ Builtin types            | Placeholder -- ^ Underscore            | PDoBlock [PDo] -- ^ Do notation            | PIdiom FC PTerm -- ^ Idiom brackets            | PReturn FC-           | PMetavar Name -- ^ A metavariable, ?name+           | PMetavar FC Name -- ^ A metavariable, ?name, and its precise location            | PProof [PTactic] -- ^ Proof script            | PTactics [PTactic] -- ^ As PProof, but no auto solving            | PElabError Err -- ^ Error to report on elaboration@@ -812,9 +856,13 @@            | PNoImplicits PTerm -- ^ never run implicit converions on the term            | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term])            | PUnquote PTerm -- ^ ~Term-           | PRunTactics FC PTerm -- ^ %runTactics tm - New-style proof script+           | PQuoteName Name -- ^ `{n}+           | PRunElab FC PTerm -- ^ %runElab tm - New-style proof script        deriving (Eq, Data, Typeable) +data PAltType = ExactlyOne Bool -- ^ flag sets whether delay is allowed+              | FirstSuccess +       deriving (Eq, Data, Typeable)  {-! deriving instance Binary PTerm@@ -823,15 +871,15 @@  mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm mapPT f t = f (mpt t) where-  mpt (PLam fc n t s) = PLam fc n (mapPT f t) (mapPT f s)-  mpt (PPi p n t s) = PPi p n (mapPT f t) (mapPT f s)-  mpt (PLet fc n ty v s) = PLet fc n (mapPT f ty) (mapPT f v) (mapPT f s)+  mpt (PLam fc n nfc t s) = PLam fc n nfc (mapPT f t) (mapPT f s)+  mpt (PPi p n nfc t s) = PPi p n nfc (mapPT f t) (mapPT f s)+  mpt (PLet fc n nfc ty v s) = PLet fc n nfc (mapPT f ty) (mapPT f v) (mapPT f s)   mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s)                                  (fmap (mapPT f) g)   mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)   mpt (PAppBind fc t as) = PAppBind fc (mapPT f t) (map (fmap (mapPT f)) as)   mpt (PCase fc c os) = PCase fc (mapPT f c) (map (pmap (mapPT f)) os)-  mpt (PEq fc lt rt l r) = PEq fc (mapPT f lt) (mapPT f rt) (mapPT f l) (mapPT f r)+  mpt (PIfThenElse fc c t e) = PIfThenElse fc (mapPT f c) (mapPT f t) (mapPT f e)   mpt (PTyped l r) = PTyped (mapPT f l) (mapPT f r)   mpt (PPair fc p l r) = PPair fc p (mapPT f l) (mapPT f r)   mpt (PDPair fc p l t r) = PDPair fc p (mapPT f l) (mapPT f t) (mapPT f r)@@ -912,9 +960,9 @@ type PTactic = PTactic' PTerm  data PDo' t = DoExp  FC t-            | DoBind FC Name t+            | DoBind FC Name FC t -- ^ second FC is precise name location             | DoBindP FC t t [(t,t)]-            | DoLet  FC Name t t+            | DoLet  FC Name FC t t -- ^ second FC is precise name location             | DoLetP FC t t     deriving (Eq, Functor, Data, Typeable) {-!@@ -924,9 +972,9 @@  instance Sized a => Sized (PDo' a) where   size (DoExp fc t) = 1 + size fc + size t-  size (DoBind fc nm t) = 1 + size fc + size nm + size t+  size (DoBind fc nm nfc t) = 1 + size fc + size nm + size nfc + size t   size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts-  size (DoLet fc nm l r) = 1 + size fc + size nm + size l + size r+  size (DoLet fc nm nfc l r) = 1 + size fc + size nm + size l + size r   size (DoLetP fc l r) = 1 + size fc + size l + size r  type PDo = PDo' PTerm@@ -981,18 +1029,17 @@ highestFC (PRef fc _) = Just fc highestFC (PInferRef fc _) = Just fc highestFC (PPatvar fc _) = Just fc-highestFC (PLam fc _ _ _) = Just fc-highestFC (PPi  _ _ _ _) = Nothing-highestFC (PLet fc _ _ _ _) = Just fc+highestFC (PLam fc _ _ _ _) = Just fc+highestFC (PPi _ _ _ _ _) = Nothing+highestFC (PLet fc _ _ _ _ _) = Just fc highestFC (PTyped tm ty) = highestFC tm <|> highestFC ty highestFC (PApp fc _ _) = Just fc highestFC (PAppBind fc _ _) = Just fc highestFC (PMatchApp fc _) = Just fc highestFC (PCase fc _ _) = Just fc+highestFC (PIfThenElse fc _ _ _) = Just fc highestFC (PTrue fc _) = Just fc-highestFC (PRefl fc _) = Just fc highestFC (PResolveTC fc) = Just fc-highestFC (PEq fc _ _ _ _) = Just fc highestFC (PRewrite fc _ _ _) = Just fc highestFC (PPair fc _ _ _) = Just fc highestFC (PDPair fc _ _ _ _) = Just fc@@ -1002,10 +1049,10 @@     [] -> Nothing     (fc:_) -> Just fc highestFC (PHidden _) = Nothing-highestFC PType = Nothing+highestFC (PType fc) = Just fc highestFC (PUniverse _) = Nothing highestFC (PGoal fc _ _ _) = Just fc-highestFC (PConstant _) = Nothing+highestFC (PConstant fc _) = Just fc highestFC Placeholder = Nothing highestFC (PDoBlock lines) =   case map getDoFC lines of@@ -1013,14 +1060,14 @@     (fc:_) -> Just fc   where     getDoFC (DoExp fc t)          = fc-    getDoFC (DoBind fc nm t)      = fc+    getDoFC (DoBind fc nm nfc t)  = fc     getDoFC (DoBindP fc l r alts) = fc-    getDoFC (DoLet fc nm l r)     = fc+    getDoFC (DoLet fc nm nfc l r) = fc     getDoFC (DoLetP fc l r)       = fc  highestFC (PIdiom fc _) = Just fc highestFC (PReturn fc) = Just fc-highestFC (PMetavar _) = Nothing+highestFC (PMetavar fc _) = Just fc highestFC (PProof _) = Nothing highestFC (PTactics _) = Nothing highestFC (PElabError _) = Nothing@@ -1031,15 +1078,16 @@ highestFC (PNoImplicits tm) = highestFC tm highestFC (PQuasiquote _ _) = Nothing highestFC (PUnquote tm) = highestFC tm+highestFC (PQuoteName _) = Nothing  -- Type class data -data ClassInfo = CI { instanceName :: Name,+data ClassInfo = CI { instanceCtorName :: 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],+                      class_instances :: [(Name, Bool)], -- the Bool is whether to include in instance search, so named instances are excluded                       class_determiners :: [Int] }     deriving Show {-!@@ -1069,20 +1117,7 @@ deriving instance NFData OptInfo !-} --data TypeInfo = TI { con_names :: [Name],-                     codata :: Bool,-                     data_opts :: DataOpts,-                     param_pos :: [Int],-                     mutual_types :: [Name] }-    deriving Show-{-!-deriving instance Binary TypeInfo-deriving instance NFData TypeInfo-!-}---- Syntactic sugar info-+-- | Syntactic sugar info data DSL' t = DSL { dsl_bind    :: t,                     dsl_return  :: t,                     dsl_apply   :: t,@@ -1232,10 +1267,10 @@  inferTy   = sMN 0 "__Infer" inferCon  = sMN 0 "__infer"-inferDecl = PDatadecl inferTy-                      PType-                      [(emptyDocstring, [], inferCon, PPi impl (sMN 0 "iType") PType (-                                                   PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))+inferDecl = PDatadecl inferTy NoFC+                      (PType bi)+                      [(emptyDocstring, [], inferCon, NoFC, PPi impl (sMN 0 "iType") NoFC (PType bi) (+                                                   PPi expl (sMN 0 "ival") NoFC (PRef bi (sMN 0 "iType"))                                                    (PRef bi inferTy)), bi, [])] inferOpts = [] @@ -1244,20 +1279,20 @@  getInferTerm, getInferType :: Term -> Term getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc-getInferTerm (App (App _ _) tm) = tm+getInferTerm (App _ (App _ _ _) tm) = tm getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)  getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc   where toTy (Lam t) = Pi Nothing t (TType (UVar 0))         toTy (PVar t) = PVTy t         toTy b = b-getInferType (App (App _ ty) _) = ty+getInferType (App _ (App _ _ ty) _) = ty    -- Handy primitives: Unit, False, Pair, MkPair, =, mkForeign -primNames = [eqTy, eqCon, inferTy, inferCon]+primNames = [inferTy, inferCon]  unitTy   = sUN "Unit" unitCon  = sUN "MkUnit"@@ -1289,16 +1324,16 @@           "\n\n" ++           "You may need to use `(~=~)` to explicitly request heterogeneous equality." -eqDecl = PDatadecl eqTy (piBindp impl [(n "A", PType), (n "B", PType)]-                                 (piBind [(n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]-                                 PType))+eqDecl = PDatadecl eqTy NoFC (piBindp impl [(n "A", PType bi), (n "B", PType bi)]+                                      (piBind [(n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]+                                      (PType bi)))                 [(reflDoc, reflParamDoc,-                  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, [])]+                  eqCon, NoFC, PPi impl (n "A") NoFC (PType bi) (+                                        PPi impl (n "x") NoFC (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 = sUN a           reflDoc = annotCode (const (Left $ Msg "")) . parseDocstring . T.pack $                       "A proof that `x` in fact equals `x`. To construct this, you must have already " ++@@ -1321,14 +1356,14 @@  -- Defined in builtins.idr sigmaTy   = sNS (sUN "Sigma") ["Builtins"]-existsCon = sNS (sUN "MkSigma") ["Builtins"]+sigmaCon = sNS (sUN "MkSigma") ["Builtins"]  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)+piBindp p ((n, ty):ns) t = PPi p n NoFC ty (piBindp p ns t)   -- Pretty-printing declarations and terms@@ -1417,18 +1452,18 @@       | Just str <- slist p bnd e = str       | Just n <- snat p e = annotate (AnnData "Nat" "") (text (show n))     prettySe p bnd (PRef fc n) = prettyName True (ppopt_impl ppo) bnd n-    prettySe p bnd (PLam fc n ty sc) =+    prettySe p bnd (PLam fc n nfc ty sc) =       bracket p startPrec . group . align . hang 2 $-      text "\\" <> bindingOf n False <+> text "=>" <$>+      text "\\" <> prettyBindingOf n False <+> text "=>" <$>       prettySe startPrec ((n, False):bnd) sc-    prettySe p bnd (PLet fc n ty v sc) =+    prettySe p bnd (PLet fc n nfc ty v sc) =       bracket p startPrec . group . align $-      kwd "let" <+> (group . align . hang 2 $ bindingOf n False <+> text "=" <$> prettySe startPrec bnd v) </>+      kwd "let" <+> (group . align . hang 2 $ prettyBindingOf n False <+> text "=" <$> prettySe startPrec bnd v) </>       kwd "in" <+> (group . align . hang 2 $ prettySe startPrec ((n, False):bnd) sc)-    prettySe p bnd (PPi (Exp l s _) n ty sc)+    prettySe p bnd (PPi (Exp l s _) n _ ty sc)       | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs =           bracket p startPrec . group $-          enclose lparen rparen (group . align $ bindingOf n False <+> colon <+> prettySe startPrec bnd ty) <+>+          enclose lparen rparen (group . align $ prettyBindingOf n False <+> colon <+> prettySe startPrec bnd ty) <+>           st <> text "->" <$> prettySe startPrec ((n, False):bnd) sc       | otherwise                      =           bracket p startPrec . group $@@ -1438,10 +1473,10 @@           case s of             Static -> text "[static]" <> space             _      -> empty-    prettySe p bnd (PPi (Imp l s _ fa) n ty sc)+    prettySe p bnd (PPi (Imp l s _ fa) n _ ty sc)       | ppopt_impl ppo =           bracket p startPrec $-          lbrace <> bindingOf n True <+> colon <+> prettySe startPrec bnd ty <> rbrace <+>+          lbrace <> prettyBindingOf n True <+> colon <+> prettySe startPrec bnd ty <> rbrace <+>           st <> text "->" </> prettySe startPrec ((n, True):bnd) sc       | otherwise = prettySe startPrec ((n, True):bnd) sc       where@@ -1449,13 +1484,31 @@           case s of             Static -> text "[static]" <> space             _      -> empty-    prettySe p bnd (PPi (Constraint _ _) n ty sc) =+    prettySe p bnd (PPi (Constraint _ _) n _ ty sc) =       bracket p startPrec $       prettySe (startPrec + 1) bnd ty <+> text "=>" </> prettySe startPrec ((n, True):bnd) sc-    prettySe p bnd (PPi (TacImp _ _ s) n ty sc) =+    prettySe p bnd (PPi (TacImp _ _ (PTactics [ProofSearch _ _ _ _ _])) n _ ty sc) =+      lbrace <> kwd "auto" <+> pretty n <+> colon <+> prettySe startPrec bnd ty <>+      rbrace <+> text "->" </> prettySe startPrec ((n, True):bnd) sc+    prettySe p bnd (PPi (TacImp _ _ s) n _ ty sc) =       bracket p startPrec $-      lbrace <> kwd "tacimp" <+> pretty n <+> colon <+> prettySe startPrec bnd ty <>+      lbrace <> kwd "default" <+> prettySe (funcAppPrec + 1) bnd s <+> pretty n <+> colon <+> prettySe startPrec bnd ty <>       rbrace <+> text "->" </> prettySe startPrec ((n, True):bnd) sc+    -- This case preserves the behavior of the former constructor PEq.+    -- It should be removed if feasible when the pretty-printing of infix+    -- operators in general is improved.+    prettySe p bnd (PApp _ (PRef _ n) [lt, rt, l, r])+      | n == eqTy, ppopt_impl ppo =+          bracket p eqPrec $+            enclose lparen rparen eq <+>+            align (group (vsep (map (prettyArgS bnd)+                                    [lt, rt, l, r])))+      | n == eqTy =+          bracket p eqPrec . align . group $+            prettyTerm (getTm l) <+> eq <$> group (prettyTerm (getTm r))+      where eq = annName eqTy (text "=")+            eqPrec = startPrec+            prettyTerm = prettySe (eqPrec + 1) bnd     prettySe p bnd (PApp _ (PRef _ f) args) -- normal names, no explicit args       | UN nm <- basename f       , not (ppopt_impl ppo) && null (getShowArgs args) =@@ -1490,7 +1543,7 @@                   (prettySe left bnd l <+> opName False) <$>                     group (prettySe right bnd r)     prettySe p bnd (PApp _ hd@(PRef fc f) [tm]) -- symbols, like 'foo-      | PConstant (Idris.Core.TT.Str str) <- getTm tm,+      | PConstant NoFC (Idris.Core.TT.Str str) <- getTm tm,         f == sUN "Symbol_" = annotate (AnnType ("'" ++ str) ("The symbol " ++ str)) $                                char '\'' <> prettySe startPrec bnd (PRef fc (sUN str))     prettySe p bnd (PApp _ f as) = -- Normal prefix applications@@ -1524,27 +1577,17 @@         noNS (NS _ _) = False         noNS _ = True +    prettySe p bnd (PIfThenElse _ c t f) =+      group . align . hang 2 . vsep $+        [ kwd "if" <+> prettySe startPrec bnd c+        , kwd "then" <+> prettySe startPrec bnd t+        , kwd "else" <+> prettySe startPrec bnd f+        ]     prettySe p bnd (PHidden tm) = text "." <> prettySe funcAppPrec bnd tm-    prettySe p bnd (PRefl _ _) = annName eqCon $ text "Refl"-    prettySe p bnd (PResolveTC _) = text "resolvetc"+    prettySe p bnd (PResolveTC _) = kwd "%instance"     prettySe p bnd (PTrue _ IsType) = annName unitTy $ text "()"     prettySe p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"     prettySe p bnd (PTrue _ TypeOrTerm) = text "()"-    prettySe p bnd (PEq _ lt rt l r)-      | ppopt_impl ppo =-          bracket p eqPrec $-            enclose lparen rparen eq <+>-            align (group (vsep (map (prettyArgS bnd)-                                    [PImp 0 False [] (sUN "A") lt,-                                     PImp 0 False [] (sUN "B") rt,-                                     PExp 0 [] (sUN "x") l,-                                     PExp 0 [] (sUN "y") r])))-      | otherwise =-          bracket p eqPrec . align . group $-            prettyTerm l <+> eq <$> group (prettyTerm r)-      where eq = annName eqTy (text "=")-            eqPrec = startPrec-            prettyTerm = prettySe (eqPrec + 1) bnd     prettySe p bnd (PRewrite _ l r _) =       bracket p startPrec $       text "rewrite" <+> prettySe (startPrec + 1) bnd l <+> text "in" <+> prettySe startPrec bnd r@@ -1566,25 +1609,25 @@       annotated rparen       where annotated = case pun of               IsType -> annName sigmaTy-              IsTerm -> annName existsCon+              IsTerm -> annName sigmaCon               TypeOrTerm -> id             (left, addBinding) = case (l, pun) of-              (PRef _ n, IsType) -> (bindingOf n False,        ((n, False) :))+              (PRef _ n, IsType) -> (bindingOf n False <+> text ":" <+> prettySe startPrec bnd t,        ((n, False) :))               _ ->                  (prettySe startPrec bnd l, id            )     prettySe p bnd (PAlternative a as) =       lparen <> text "|" <> prettyAs <> text "|" <> rparen         where           prettyAs =             foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe startPrec bnd) as-    prettySe p bnd PType = annotate (AnnType "Type" "The type of types") $ text "Type"+    prettySe p bnd (PType _) = annotate (AnnType "Type" "The type of types") $ text "Type"     prettySe p bnd (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u)-    prettySe p bnd (PConstant c) = annotate (AnnConst c) (text (show c))+    prettySe p bnd (PConstant _ c) = annotate (AnnConst c) (text (show c))     -- XXX: add pretty for tactics     prettySe p bnd (PProof ts) =-      text "proof" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace+      kwd "proof" <+> lbrace <> text "..." <> rbrace     prettySe p bnd (PTactics ts) =-      text "tactics" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace-    prettySe p bnd (PMetavar n) = text "?" <> pretty n+      kwd "tactics" <+> lbrace <> text "..." <> rbrace+    prettySe p bnd (PMetavar _ n) = annotate (AnnName n (Just MetavarOutput) Nothing Nothing) $  text "?" <> pretty n     prettySe p bnd (PReturn f) = kwd "return"     prettySe p bnd PImpossible = kwd "impossible"     prettySe p bnd Placeholder = text "_"@@ -1595,9 +1638,18 @@     prettySe p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe p [] t <> text ")"     prettySe p bnd (PQuasiquote t (Just g)) = text "`(" <> prettySe p [] t <+> colon <+> prettySe p [] g <> text ")"     prettySe p bnd (PUnquote t) = text "~" <> prettySe p bnd t+    prettySe p bnd (PQuoteName n) = text "`{" <> prettyName True (ppopt_impl ppo) bnd n <> text "}"      prettySe p bnd _ = text "missing pretty-printer for term" +    prettyBindingOf :: Name -> Bool -> Doc OutputAnnotation+    prettyBindingOf n imp = annotate (AnnBoundName n imp) (text (display n))+      where display (UN n)    = T.unpack n+            display (MN _ n)  = T.unpack n+            -- If a namespace is specified on a binding form, we'd better show it regardless of the implicits settings+            display (NS n ns) = (concat . intersperse "." . map T.unpack . reverse) ns ++ "." ++ display n+            display n         = show n+     prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)     prettyArgS bnd (PExp _ _ _ tm)   = prettyArgSe bnd tm     prettyArgS bnd (PConstraint _ _ _ tm) = prettyArgSc bnd tm@@ -1615,10 +1667,8 @@     opStr (NS n _) = opStr n     opStr (UN n) = T.unpack n -    basename :: Name -> Name-    basename (NS n _) = basename n-    basename n = n-+    slist' _ _ e+      | containsHole e = Nothing     slist' p bnd (PApp _ (PRef _ nil) _)       | not (ppopt_impl ppo) && nsroot nil == sUN "Nil" = Just []     slist' p bnd (PRef _ nil)@@ -1674,6 +1724,11 @@     getFixity :: String -> Maybe Fixity     getFixity = flip M.lookup fixities +-- | Strip away namespace information+basename :: Name -> Name+basename (NS n _) = basename n+basename n = n+ -- | Determine whether a name was the one inserted for a hole or -- guess by the delaborator isHoleName :: Name -> Bool@@ -1726,31 +1781,28 @@   showDImp :: PPOption -> PData -> Doc OutputAnnotation-showDImp ppo (PDatadecl n ty cons)+showDImp ppo (PDatadecl n nfc ty cons)  = text "data" <+> text (show n) <+> colon <+> prettyImp ppo ty <+> text "where" <$>-    (indent 2 $ vsep (map (\ (_, _, n, t, _, _) -> pipe <+> prettyName True False [] n <+> colon <+> prettyImp ppo t) cons))+    (indent 2 $ vsep (map (\ (_, _, n, _, t, _, _) -> pipe <+> prettyName True False [] n <+> colon <+> prettyImp ppo t) cons))  showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation showDecls o ds = vsep (map (showDeclImp o) ds)  showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))-showDeclImp o (PTy _ _ _ _ _ n t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp o t+showDeclImp o (PTy _ _ _ _ _ n _ t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp o t showDeclImp o (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>                                       indent 2 (vsep (map (showCImp o) cs)) showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d showDeclImp o (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)-showDeclImp o (PNamespace n ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)+showDeclImp o (PNamespace n fc ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line) showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)-showDeclImp o (PClass _ _ _ cs n ps _ _ ds)+showDeclImp o (PClass _ _ _ cs n _ ps _ _ ds _ _)    = text "class" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds-showDeclImp o (PInstance _ _ _ _ cs n _ t _ ds)+showDeclImp o (PInstance _ _ _ _ cs n _ _ t _ ds)    = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds showDeclImp _ _ = text "..." -- showDeclImp (PImport o) = "import " ++ o -instance Show (Doc OutputAnnotation) where-  show = flip (displayS . renderCompact) ""- getImps :: [PArg] -> [(Name, PTerm)] getImps [] = [] getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs@@ -1823,17 +1875,16 @@ instance Sized PTerm where   size (PQuote rawTerm) = size rawTerm   size (PRef fc name) = size name-  size (PLam fc name ty bdy) = 1 + size ty + size bdy-  size (PPi plicity name ty bdy) = 1 + size ty + size bdy-  size (PLet fc name ty def bdy) = 1 + size ty + size def + size bdy+  size (PLam fc name _ ty bdy) = 1 + size ty + size bdy+  size (PPi plicity name fc ty bdy) = 1 + size ty + size fc + size bdy+  size (PLet fc name nfc ty def bdy) = 1 + size ty + size def + size bdy   size (PTyped trm ty) = 1 + size trm + size ty   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 (PIfThenElse fc c t f) = 1 + sum (map size [c, t, f])   size (PTrue 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 (PDPair fs _ left ty right) = 1 + size left + size ty + size right@@ -1842,21 +1893,21 @@   size (PUnifyLog tm) = size tm   size (PDisamb _ tm) = size tm   size (PNoImplicits tm) = size tm-  size PType = 1+  size (PType _) = 1   size (PUniverse _) = 1-  size (PConstant const) = 1 + size const+  size (PConstant fc const) = 1 + size fc + size const   size Placeholder = 1   size (PDoBlock dos) = 1 + size dos   size (PIdiom fc term) = 1 + size term   size (PReturn fc) = 1-  size (PMetavar name) = 1+  size (PMetavar _ name) = 1   size (PProof tactics) = size tactics   size (PElabError err) = size err   size PImpossible = 1   size _ = 0  getPArity :: PTerm -> Int-getPArity (PPi _ _ _ sc) = 1 + getPArity sc+getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc getPArity _ = 0  -- Return all names, free or globally bound, in the given term.@@ -1870,10 +1921,10 @@     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)-    ni env (PLam fc n ty sc)  = ni env ty ++ ni (n:env) sc-    ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc+    ni env (PIfThenElse _ c t f) = ni env c ++ ni env t ++ ni env f+    ni env (PLam fc n _ ty sc)  = ni env ty ++ ni (n:env) sc+    ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc     ni env (PHidden tm)    = ni env tm-    ni env (PEq _ _ _ l r)     = ni env l ++ ni env r     ni env (PRewrite _ l r _) = ni env l ++ ni env r     ni env (PTyped l r)    = ni env l ++ ni env r     ni env (PPair _ _ l r)   = ni env l ++ ni env r@@ -1888,32 +1939,36 @@     niTacImp env (TacImp _ _ scr) = ni env scr     niTacImp _ _                   = [] + -- Return all names defined in binders in the given term boundNamesIn :: PTerm -> [Name]-boundNamesIn tm = nub $ ni tm+boundNamesIn tm = S.toList (ni S.empty tm)   where -- TODO THINK Added niTacImp, but is it right?-    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 fc n ty sc)  = n : (ni ty ++ ni sc)-    ni (PLet fc n ty val sc)  = n : (ni ty ++ ni val ++ ni sc)-    ni (PPi p n ty sc) = niTacImp p ++ (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 _               = []+    ni set (PApp _ f as) = niTms (ni set f) (map getTm as)+    ni set (PAppBind _ f as) = niTms (ni set f) (map getTm as)+    ni set (PCase _ c os)  = niTms (ni set c) (map snd os)+    ni set (PIfThenElse _ c t f) = niTms set [c, t, f]+    ni set (PLam fc n _ ty sc)  = S.insert n $ ni (ni set ty) sc+    ni set (PLet fc n nfc ty val sc) = S.insert n $ ni (ni (ni set ty) val) sc+    ni set (PPi p n _ ty sc) = niTacImp (S.insert n $ ni (ni set ty) sc) p+    ni set (PRewrite _ l r _) = ni (ni set l) r+    ni set (PTyped l r) = ni (ni set l) r+    ni set (PPair _ _ l r) = ni (ni set l) r+    ni set (PDPair _ _ (PRef _ n) t r) = ni (ni set t) r+    ni set (PDPair _ _ l t r) = ni (ni (ni set l) t) r+    ni set (PAlternative a as) = niTms set as+    ni set (PHidden tm) = ni set tm+    ni set (PUnifyLog tm) = ni set tm+    ni set (PDisamb _ tm) = ni set tm+    ni set (PNoImplicits tm) = ni set tm+    ni set _               = set -    niTacImp (TacImp _ _ scr) = ni scr-    niTacImp _                = []+    niTms set [] = set+    niTms set (x : xs) = niTms (ni set x) xs +    niTacImp set (TacImp _ _ scr) = ni set scr+    niTacImp set _                = set+ -- Return names which are valid implicits in the given term (type). implicitNamesIn :: [Name] -> IState -> PTerm -> [Name] implicitNamesIn uvars ist tm = nub $ ni [] tm@@ -1932,9 +1987,9 @@     -- names in 'os', not counting the names bound in the cases                                 (nub (concatMap (ni env) (map snd os))                                      \\ nub (concatMap (ni env) (map fst os)))-    ni env (PLam fc n ty sc)  = ni env ty ++ ni (n:env) sc-    ni env (PPi p n ty sc) = ni env ty ++ ni (n:env) sc-    ni env (PEq _ _ _ l r)     = ni env l ++ ni env r+    ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]+    ni env (PLam fc n _ ty sc)  = ni env ty ++ ni (n:env) sc+    ni env (PPi p n _ ty sc) = ni env ty ++ ni (n:env) sc     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@@ -1962,9 +2017,9 @@     -- names in 'os', not counting the names bound in the cases                                 (nub (concatMap (ni env) (map snd os))                                      \\ nub (concatMap (ni env) (map fst os)))-    ni env (PLam fc n ty sc)  = ni env ty ++ ni (n:env) sc-    ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc-    ni env (PEq _ _ _ l r)     = ni env l ++ ni env r+    ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]+    ni env (PLam fc n nfc ty sc)  = ni env ty ++ ni (n:env) sc+    ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc     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@@ -1993,9 +2048,9 @@     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)-    ni env (PLam fc n ty sc)  = ni env ty ++ ni (n:env) sc-    ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc-    ni env (PEq _ _ _ l r)     = ni env l ++ ni env r+    ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]+    ni env (PLam fc n _ ty sc)  = ni env ty ++ ni (n:env) sc+    ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc     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
src/Idris/Apropos.hs view
@@ -55,7 +55,7 @@                   | (n == pairTy || n == pairCon) && str == T.pack "," = True                   | n == eqTy && str == T.pack "=" = True                   | n == eqCon && (T.toLower str) == T.pack "Refl" = True-                  | (n == sigmaTy || n == existsCon) && str == T.pack "**" = True+                  | (n == sigmaTy || n == sigmaCon) && str == T.pack "**" = True   isApropos _   _          = False -- we don't care about case blocks, MNs, etc  instance Apropos Def where@@ -77,7 +77,7 @@   isApropos str (P (DCon _ _ _) n ty) = isApropos str n || isApropos str ty   isApropos str (P Bound _ ty)      = isApropos str ty   isApropos str (Bind n b tm)       = isApropos str b || isApropos str tm-  isApropos str (App t1 t2)         = isApropos str t1 || isApropos str t2+  isApropos str (App _ t1 t2)       = isApropos str t1 || isApropos str t2   isApropos str (Constant const)    = isApropos str const   isApropos str _                   = False
src/Idris/CaseSplit.hs view
@@ -10,13 +10,13 @@ import Idris.AbsSyntax import Idris.AbsSyntaxTree (Idris, IState, PTerm) import Idris.ElabDecls-import Idris.ElabTerm import Idris.Delaborate import Idris.Parser import Idris.Error import Idris.Output  import Idris.Elab.Value+import Idris.Elab.Term  import Idris.Core.TT import Idris.Core.Typecheck@@ -69,7 +69,7 @@         let t = mergeUserImpl (addImplPat ist t') (delab ist tm)          let ctxt = tt_ctxt ist         case lookup n pats of-             Nothing -> fail $ show n ++ " is not a pattern variable"+             Nothing -> ifail $ show n ++ " is not a pattern variable"              Just ty ->                 do let splits = findPats ist ty                    iLOG ("New patterns " ++ showSep ", "  @@ -240,7 +240,6 @@         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) = Placeholder -- PEq fc (subst l) (subst r)         subst x = x          substArg arg = arg { getTm = subst (getTm arg) }@@ -346,22 +345,21 @@                       return (show fn ++ " " ++ ap ++ "= ?"                                        ++ show fn ++ "_rhs")    where mkApp :: IState -> PTerm -> [Name] -> String-         mkApp i (PPi (Exp _ _ False) (MN _ _) ty sc) used+         mkApp i (PPi (Exp _ _ False) (MN _ _) _ ty sc) used                = let n = getNameFrom i used ty in                      show n ++ " " ++ mkApp i sc (n : used) -         mkApp i (PPi (Exp _ _ False) (UN n) ty sc) used+         mkApp i (PPi (Exp _ _ False) (UN n) _ ty sc) used             | thead n == '_'                = let n = getNameFrom i used ty in                      show n ++ " " ++ mkApp i sc (n : used) -         mkApp i (PPi (Exp _ _ False) n _ sc) used +         mkApp i (PPi (Exp _ _ False) n _ _ sc) used                 = show n ++ " " ++ mkApp i sc (n : used) -         mkApp i (PPi _ _ _ sc) used = mkApp i sc used+         mkApp i (PPi _ _ _ _ sc) used = mkApp i sc used          mkApp i _ _ = "" -         getNameFrom i used (PPi _ _ _ _) +         getNameFrom i used (PPi _ _ _ _ _)               = uniqueNameFrom (mkSupply [sUN "f", sUN "g"]) used          getNameFrom i used (PApp fc f as) = getNameFrom i used f-         getNameFrom i used (PEq _ _ _ _ _) = uniqueNameFrom (mkSupply [sUN "prf"]) used           getNameFrom i used (PRef fc f)              = case getNameHints i f of                    [] -> uniqueName (sUN "x") used@@ -388,7 +386,7 @@ getProofClause l fn fp                   = do ty <- getInternalApp fp l                        return (mkApp ty ++ " = ?" ++ show fn ++ "_rhs")-   where mkApp (PPi _ _ _ sc) = mkApp sc+   where mkApp (PPi _ _ _ _ sc) = mkApp sc          mkApp rt = "(" ++ show rt ++ ") <== " ++ show fn  -- Purely syntactic - turn a pattern match clause into a with and a new
src/Idris/Chaser.hs view
@@ -15,6 +15,7 @@ import Data.List  import Debug.Trace+import Util.System (readSource, writeSource)  data ModuleTree = MTree { mod_path :: IFileType,                           mod_needsRecheck :: Bool,@@ -64,6 +65,16 @@                                   then getSrc x : updateToSrc path xs                                   else x : updateToSrc path xs +-- Strip quotes and the backslash escapes that Haskeline adds+extractFileName :: String -> String+extractFileName ('"':xs) = takeWhile (/= '"') xs+extractFileName ('\'':xs) = takeWhile (/= '\'') xs+extractFileName x = build x []+                        where+                            build [] acc = reverse $ dropWhile (== ' ') acc+                            build ('\\':' ':xs) acc = build xs (' ':acc)+                            build (x:xs) acc = build xs (x:acc)+ getIModTime (IBC i _) = getModificationTime i getIModTime (IDR i) = getModificationTime i getIModTime (LIDR i) = getModificationTime i@@ -78,7 +89,7 @@  where   btree done f =     do i <- getIState-       let file = takeWhile (/= ' ') f+       let file = extractFileName f        iLOG $ "CHASING " ++ show file        ibcsd <- valIBCSubDir i        ids <- allImportDirs@@ -133,12 +144,12 @@   children lit f done = -- idrisCatch      do exist <- runIO $ doesFileExist f         if exist then do-            file_in <- runIO $ readFile f+            file_in <- runIO $ readSource f             file <- if lit then tclift $ unlit f file_in else return file_in             (_, _, modules, _) <- parseImports f file             -- The chaser should never report warnings from sub-modules             clearParserWarnings-            ms <- mapM (btree done) [realName | (_, realName, alias, fc) <- modules]+            ms <- mapM (btree done . import_path) modules             return (concat ms)            else return [] -- IBC with no source available --     (\c -> return []) -- error, can't chase modules here
src/Idris/Core/Binary.hs view
@@ -3,10 +3,14 @@ {-| Binary instances for the core datatypes -} module Idris.Core.Binary where +import Control.Applicative ((<*>), (<$>))+import Control.Monad (liftM2)+import Control.DeepSeq (($!!))+ import Data.Binary import Data.Vector.Binary import qualified Data.Text as T-+import qualified Data.Text.Encoding as E import Idris.Core.TT  instance Binary ErrorReportPart where@@ -43,6 +47,22 @@                      return (TooManyArgs x1)              _ -> error "Corrupted binary data for Provenance" +instance Binary UConstraint where+  put (ULT x1 x2) = putWord8 0 >> put x1 >> put x2+  put (ULE x1 x2) = putWord8 1 >> put x1 >> put x2+  get = do i <- getWord8+           case i of+             0 -> ULT <$> get <*> get+             1 -> ULE <$> get <*> get+             _ -> error "Corrupted binary data for UConstraint"++instance Binary ConstraintFC where+  put (ConstraintFC x1 x2) = putWord8 0 >> put x1 >> put x2+  get = do i <- getWord8+           case i of+             0 -> liftM2 ConstraintFC get get+             _ -> error "Corrupted binary data for ConstraintFC"+ instance Binary a => Binary (Err' a) where   put (Msg str) = do putWord8 0                      put str@@ -97,7 +117,12 @@                                 put ns   put (IncompleteTerm t) = do putWord8 17                               put t-  put UniverseError = putWord8 18+  put (UniverseError x1 x2 x3 x4 x5) = do putWord8 18+                                          put x1+                                          put x2+                                          put x3+                                          put x4+                                          put x5   put (UniqueError u n) = do putWord8 19                              put u                              put n@@ -142,16 +167,18 @@                           put t   put (CantMatch t) = do putWord8 35                          put t-  put (ElabDebug x1 x2 x3) = do putWord8 36-                                put x1-                                put x2-                                put x3+  put (ElabScriptDebug x1 x2 x3) = do putWord8 36+                                      put x1+                                      put x2+                                      put x3   put (NoEliminator s t) = do putWord8 37                               put s                               put t   put (InvalidTCArg n t) = do putWord8 38                               put n                               put t+  put (ElabScriptStuck x1) = do putWord8 39+                                put x1    get = do i <- getWord8            case i of@@ -181,7 +208,7 @@              15 -> fmap (CantResolve False) get              16 -> fmap CantResolveAlts get              17 -> fmap IncompleteTerm get-             18 -> return UniverseError+             18 -> UniverseError <$> get <*> get <*> get <*> get <*> get              19 -> do x <- get ; y <- get                       return $ UniqueError x y              20 -> do x <- get ; y <- get@@ -210,26 +237,39 @@              36 -> do x1 <- get                       x2 <- get                       x3 <- get-                      return (ElabDebug x1 x2 x3)+                      return (ElabScriptDebug x1 x2 x3)              37 -> do x1 <- get                       x2 <- get                       return (NoEliminator x1 x2)              38 -> do x1 <- get                       x2 <- get                       return (InvalidTCArg x1 x2)+             39 -> do x1 <- get+                      return (ElabScriptStuck x1)              _ -> error "Corrupted binary data for Err'" ----- Generated by 'derive'  instance Binary FC where-        put (FC x1 (x2, x3) (x4, x5))-          = do put x1-               put (x2 * 65536 + x3)-               put (x4 * 65536 + x5)+        put x =+          case x of +            (FC x1 (x2, x3) (x4, x5)) -> do putWord8 0+                                            put x1+                                            put (x2 * 65536 + x3)+                                            put (x4 * 65536 + x5)+            NoFC -> putWord8 1+            FileFC x1 -> do putWord8 2+                            put x1         get-          = do x1 <- get-               x2x3 <- get-               x4x5 <- get-               return (FC x1 (x2x3 `div` 65536, x2x3 `mod` 65536) (x4x5 `div` 65536, x4x5 `mod` 65536))+          = do i <- getWord8+               case i of+                 0 -> do x1 <- get+                         x2x3 <- get+                         x4x5 <- get+                         return (FC x1 (x2x3 `div` 65536, x2x3 `mod` 65536) (x4x5 `div` 65536, x4x5 `mod` 65536))+                 1 -> return NoFC+                 2 -> do x1 <- get+                         return (FileFC x1)+                 _ -> error "Corrupted binary data for FC"   instance Binary Name where@@ -267,10 +307,11 @@                    _ -> error "Corrupted binary data for Name"  instance Binary T.Text where-        put x = put (str x)+        put x = put (E.encodeUtf8 x)         get = do x <- get-                 return (txt x)+                 return $!! (E.decodeUtf8 x) + instance Binary SpecialName where         put x           = case x of@@ -292,6 +333,9 @@                 WithN x1 x2 -> do putWord8 7                                   put x1                                   put x2+                MetaN x1 x2 -> do putWord8 8+                                  put x1+                                  put x2         get           = do i <- getWord8                case i of@@ -316,6 +360,9 @@                    7 -> do x1 <- get                            x2 <- get                            return (WithN x1 x2)+                   8 -> do x1 <- get+                           x2 <- get+                           return (MetaN x1 x2)                    _ -> error "Corrupted binary data for SpecialName"  @@ -342,20 +389,8 @@                 (AType ATFloat) -> putWord8 11                 (AType (ATInt ITChar)) -> putWord8 12                 StrType -> putWord8 13-                PtrType -> putWord8 14                 Forgot -> putWord8 15                 (AType (ATInt (ITFixed ity))) -> putWord8 (fromIntegral (16 + fromEnum ity)) -- 16-19 inclusive-                (AType (ATInt (ITVec ity count))) -> do-                        putWord8 20-                        putWord8 (fromIntegral . fromEnum $ ity)-                        putWord8 (fromIntegral count)--                B8V  x1 -> putWord8 21 >> put x1-                B16V x1 -> putWord8 22 >> put x1-                B32V x1 -> putWord8 23 >> put x1-                B64V x1 -> putWord8 24 >> put x1-                BufferType -> putWord8 25-                ManagedPtrType -> putWord8 26                 VoidType -> putWord8 27                 WorldType -> putWord8 28                 TheWorld -> putWord8 29@@ -382,7 +417,6 @@                    11 -> return (AType ATFloat)                    12 -> return (AType (ATInt ITChar))                    13 -> return StrType-                   14 -> return PtrType                    15 -> return Forgot                     16 -> return (AType (ATInt (ITFixed IT8)))@@ -390,17 +424,6 @@                    18 -> return (AType (ATInt (ITFixed IT32)))                    19 -> return (AType (ATInt (ITFixed IT64))) -                   20 -> do-                        e <- getWord8-                        c <- getWord8-                        return (AType (ATInt (ITVec (toEnum . fromIntegral $ e) (fromIntegral c))))--                   21 -> fmap B8V get-                   22 -> fmap B16V get-                   23 -> fmap B32V get-                   24 -> fmap B64V get-                   25 -> return BufferType-                   26 -> return ManagedPtrType                    27 -> return VoidType                    28 -> return WorldType                    29 -> return TheWorld@@ -579,9 +602,9 @@                                     put x1                                     put x2                                     put x3-                App x1 x2 -> do putWord8 3-                                put x1-                                put x2+                App _ x1 x2 -> do putWord8 3+                                  put x1+                                  put x2                 Constant x1 -> do putWord8 4                                   put x1                 Proj x1 x2 -> do putWord8 5@@ -608,7 +631,7 @@                            return (Bind x1 x2 x3)                    3 -> do x1 <- get                            x2 <- get-                           return (App x1 x2)+                           return (App Complete x1 x2)                    4 -> do x1 <- get                            return (Constant x1)                    5 -> do x1 <- get
src/Idris/Core/CaseTree.hs view
@@ -130,16 +130,15 @@      nut ps (P _ n _) | n `elem` ps = []                      | otherwise = [n]-    nut ps (App f a) = nut ps f ++ nut ps a+    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-+-- | 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)@@ -155,7 +154,7 @@      nut ps (P Ref n _) | n `elem` ps = []                      | otherwise = [(n, [])] -- tmp-    nut ps fn@(App f a)+    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@@ -176,8 +175,8 @@ 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 (UN pfk) _, [App e w]) <- unApply fn,+directUse fn@(App _ f a)+    | (P Ref (UN pfk) _, [App _ e w]) <- unApply fn,          pfk == txt "prim_fork"              = directUse e ++ directUse w -- HACK so that fork works     | (P Ref (UN fce) _, [_, _, a]) <- unApply fn,@@ -210,8 +209,8 @@ isUsed :: SC -> Name -> Bool isUsed sc n = used sc where -  used (Case _ n' alts) = n == n' || or (map usedA alts)-  used (ProjCase t alts) = n `elem` freeNames t || or (map usedA alts)+  used (Case _ n' alts) = n == n' || any usedA alts+  used (ProjCase t alts) = n `elem` freeNames t || any usedA alts   used (STerm t) = n `elem` freeNames t   used _ = False @@ -321,10 +320,6 @@ 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 Bool Name Int [Pat]@@ -341,7 +336,7 @@  toPats :: Bool -> Bool -> Term -> [Pat] toPats reflect tc f = reverse (toPat reflect tc (getArgs f)) where-   getArgs (App f a) = a : getArgs f+   getArgs (App _ f a) = a : getArgs f    getArgs _ = []  toPat :: Bool -> Bool -> [Term] -> [Pat]@@ -366,7 +361,7 @@         = PSuc $ toPat' [] p      toPat' []   (P Bound n ty) = PV n ty-    toPat' args (App f a)      = toPat' (a : args) f+    toPat' args (App _ f a)    = toPat' (a : args) f     toPat' [] (Constant x) | isTypeConst x = PTyPat                            | otherwise     = PConst x @@ -643,7 +638,7 @@     dpa ms x (SucCase n sc) = SucCase n (dp ms sc)     dpa ms x (DefaultCase sc) = DefaultCase (dp ms sc) -    applyMaps ms f@(App _ _)+    applyMaps ms f@(App _ _ _)        | (P nt cn pty, args) <- unApply f             = let args' = map (applyMaps ms) args in                   applyMap ms nt cn pty args'@@ -656,7 +651,7 @@           same n (P _ n' _) = n == n'           same _ _ = False -    applyMaps ms (App f a) = App (applyMaps ms f) (applyMaps ms a)+    applyMaps ms (App s f a) = App s (applyMaps ms f) (applyMaps ms a)     applyMaps ms t = t  -- FIXME: Do this for SucCase too
src/Idris/Core/Constraints.hs view
@@ -145,18 +145,19 @@         domainOf (UVar var) = gets (fst . (M.! Var var) . domainStore)         domainOf (UVal val) = return (Domain val val) +        asPair :: Domain -> (Int, Int)+        asPair (Domain x y) = (x, y)+         updateUpperBoundOf :: ConstraintFC -> UExp -> Int -> StateT SolverState TC ()         updateUpperBoundOf suspect (UVar var) upper = do             doms <- gets domainStore             let (oldDom@(Domain lower _), suspects) = doms M.! Var var             let newDom = Domain lower upper-            when (wipeOut newDom) $ lift $ Error $ At (ufc suspect) $ Msg $ unlines-                $ "Universe inconsistency."-                : ("Working on: " ++ show (UVar var))-                : ("Old domain: " ++ show oldDom)-                : ("New domain: " ++ show newDom)-                : "Involved constraints: "-                : map (("\t"++) . show) (suspect : S.toList suspects)+            when (wipeOut newDom) $+              lift $ Error $+                UniverseError (ufc suspect) (UVar var)+                              (asPair oldDom) (asPair newDom)+                              (suspect : S.toList suspects)             modify $ \ st -> st { domainStore = M.insert (Var var) (newDom, S.insert suspect suspects) doms }             addToQueueRHS (uconstraint suspect) (Var var)         updateUpperBoundOf _ UVal{} _ = return ()
src/Idris/Core/DeepSeq.hs view
@@ -25,6 +25,7 @@         rnf (CaseN x1) = rnf x1 `seq` ()         rnf (ElimN x1) = rnf x1 `seq` ()         rnf (InstanceCtorN x1) = rnf x1 `seq` ()+        rnf (MetaN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()  instance NFData Universe where         rnf NullType = ()@@ -42,6 +43,8 @@  instance NFData FC where         rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf NoFC = ()+        rnf (FileFC f) = rnf f `seq` ()  instance NFData Provenance where         rnf ExpectedType = ()@@ -50,6 +53,13 @@         rnf (SourceTerm x1) = rnf x1 `seq` ()         rnf (TooManyArgs x1) = rnf x1 `seq` () +instance NFData UConstraint where+  rnf (ULT x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+  rnf (ULE x1 x2) = rnf x1 `seq` rnf x2 `seq` ()++instance NFData ConstraintFC where+  rnf (ConstraintFC x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ instance NFData Err where         rnf (Msg x1) = rnf x1 `seq` ()         rnf (InternalMsg x1) = rnf x1 `seq` ()@@ -85,7 +95,7 @@         rnf (CantResolveAlts x1) = rnf x1 `seq` ()         rnf (IncompleteTerm x1) = rnf x1 `seq` ()         rnf (NoEliminator x1 x2) = rnf x1 `seq` rnf x2 `seq` ()-        rnf UniverseError = ()+        rnf (UniverseError x1 x2 x3 x4 x5) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()         rnf ProgramLineComment = ()         rnf (Inaccessible x1) = rnf x1 `seq` ()         rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` ()@@ -97,7 +107,8 @@           = 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` ()-        rnf (ElabDebug x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (ElabScriptDebug x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (ElabScriptStuck x1) = rnf x1 `seq` ()  instance NFData ImplicitInfo where         rnf (Impl x1) = rnf x1 `seq` ()@@ -134,7 +145,6 @@         rnf ITNative = ()         rnf ITBig = ()         rnf ITChar = ()-        rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` ()  instance NFData ArithTy where         rnf (ATInt x1) = rnf x1 `seq` ()@@ -150,17 +160,10 @@         rnf (B16 x1) = rnf x1 `seq` ()         rnf (B32 x1) = rnf x1 `seq` ()         rnf (B64 x1) = rnf x1 `seq` ()-        rnf (B8V x1) = rnf x1 `seq` ()-        rnf (B16V x1) = rnf x1 `seq` ()-        rnf (B32V x1) = rnf x1 `seq` ()-        rnf (B64V x1) = rnf x1 `seq` ()         rnf (AType x1) = rnf x1 `seq` ()         rnf WorldType = ()         rnf TheWorld = ()         rnf StrType = ()-        rnf PtrType = ()-        rnf ManagedPtrType = ()-        rnf BufferType = ()         rnf VoidType = ()         rnf Forgot = () @@ -168,7 +171,7 @@         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 (App x1 x2 x3) = rnf x2 `seq` rnf x3 `seq` ()         rnf (Constant x1) = rnf x1 `seq` ()         rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf Erased = ()
src/Idris/Core/Elaborate.hs view
@@ -115,13 +115,13 @@ 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 :: Name -> Context -> Ctxt TypeInfo -> 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)+elaborate :: Context -> Ctxt TypeInfo -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)+elaborate ctxt datatypes n ty d elab = do let ps = initElaborator n ctxt datatypes ty+                                          (a, ES ps' str _) <- runElab d elab ps+                                          return $! (a, str)  -- | Modify the auxiliary state updateAux :: (aux -> aux) -> Elab' aux ()@@ -178,6 +178,14 @@ set_context ctxt = do ES (p, a) logs prev <- get                       put (ES (p { context = ctxt }, a) logs prev) +get_datatypes :: Elab' aux (Ctxt TypeInfo)+get_datatypes = do ES p _ _ <- get+                   return $! (datatypes (fst p))++set_datatypes :: Ctxt TypeInfo -> Elab' aux ()+set_datatypes ds = do ES (p, a) logs prev <- get+                      put (ES (p { datatypes = ds }, a) logs prev)+ -- | get the proof term get_term :: Elab' aux Term get_term = do ES p _ _ <- get@@ -258,7 +266,7 @@                                 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 (App _ f a) = isInj ctxt f         isInj ctxt (Constant _) = True         isInj ctxt (TType _) = True         isInj ctxt (Bind _ (Pi _ _ _) sc) = True@@ -431,7 +439,7 @@      where foB (Guess t v) = union (findOuter h env t) (findOuter h (n:env) v)            foB (Let t v) = union (findOuter h env t) (findOuter h env v)            foB b = findOuter h env (binderTy b)-  findOuter h env (App f a)+  findOuter h env (App _ f a)       = union (findOuter h env f) (findOuter h env a)   findOuter h env _ = []   @@ -541,7 +549,7 @@         | 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 (App s f a) = App s (rebind hs f) (rebind hs a)     rebind hs t = t  apply, match_apply :: Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]@@ -558,12 +566,12 @@        let dont = if null imps                       then head hs : dontunify p                      else getNonUnify (head hs : dontunify p) imps args-       let (n, hunis) = -- trace ("AVOID UNIFY: " ++ show (fn, dont) ++ "\n" ++ show ptm) $+       let (n, hunis) = -- trace ("AVOID UNIFY: " ++ show (fn, dont)) $                         unified p        let unify = -- trace ("Not done " ++ show hs) $                    dropGiven dont hunis hs-       let notunify = -- trace ("Not done " ++ show hs) $-                       keepGiven dont hunis hs+       let notunify = -- trace ("Not done " ++ show (hs, hunis)) $+                      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))@@ -739,8 +747,8 @@ try :: Elab' aux a -> Elab' aux a -> Elab' aux a try t1 t2 = try' t1 t2 False -handleError :: (Err -> Bool) -> Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a-handleError p t1 t2 proofSearch+handleError :: (Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a+handleError p t1 t2            = do s <- get                ps <- get_probs                case runStateT t1 s of@@ -759,6 +767,7 @@   = do s <- get        ps <- get_probs        ulog <- getUnifyLog+       ivs <- get_instances        case prunStateT 999999 False ps t1 s of             OK ((v, _, _), s') -> do put s'                                      return $! v@@ -779,7 +788,7 @@         recoverableErr (ProofSearchFail _) = False         recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e         recoverableErr (At _ e) = recoverableErr e-        recoverableErr (ElabDebug _ _ _) = False+        recoverableErr (ElabScriptDebug _ _ _) = False         recoverableErr _ = True  tryCatch :: Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a@@ -863,7 +872,7 @@                          hs <- get_holes                          holeInfo <- mapM getHoleInfo hs                          loadState-                         lift . Error $ ElabDebug msg (getProofTerm (pterm ps)) holeInfo+                         lift . Error $ ElabScriptDebug msg (getProofTerm (pterm ps)) holeInfo   where getHoleInfo :: Name -> Elab' aux (Name, Type, [(Name, Binder Type)])         getHoleInfo h = do focus h                            g <- goal
src/Idris/Core/Evaluate.hs view
@@ -74,12 +74,12 @@ -- | 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 []+   = evalState (do val <- eval False ctxt [] (map finalEntry 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]+   = evalState (do val <- eval False ctxt [] (map finalEntry env) t [AtREPL]                    quote 0 val) initEval  normalise :: Context -> Env -> TT Name -> TT Name@@ -285,8 +285,8 @@                      = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t     -- block reduction immediately under codata (and not forced)     ev ntimes stk top env-              (App (App (App d@(P _ (UN dly) _) l@(P _ (UN lco) _)) t) arg)-       | dly == txt "Delay" && lco == txt "LazyCodata" && not simpl+              (App _ (App _ (App _ d@(P _ (UN dly) _) l@(P _ (UN lco) _)) t) arg)+       | dly == txt "Delay" && lco == txt "LazyCodata" && not (simpl || atRepl)             = do let (f, _) = unApply arg                  let ntimes' = case f of                                     P _ fn _ -> (fn, 0) : ntimes@@ -299,11 +299,11 @@                  when spec $ setBlock False                  evApply ntimes' stk top env [l',t',arg'] d'     -- Treat "assert_total" specially, as long as it's defined!-    ev ntimes stk top env (App (App (P _ n@(UN at) _) _) arg)+    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)+    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'@@ -434,7 +434,7 @@                                  Just (altmap, sc) -> evTree ntimes stk top env altmap sc                                  _ -> return Nothing -    conHeaded tm@(App _ _)+    conHeaded tm@(App _ _ _)         | (P (DCon _ _ _) _ _, args) <- unApply tm = True     conHeaded t = False @@ -502,12 +502,9 @@     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 []@@ -543,7 +540,7 @@                                 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 (VApp f a)     = liftM2 (App MaybeHoles) (quote i f) (quote i a)     quote i (VType u)       = return $ TType u     quote i (VUType u)      = return $ UType u     quote i VErased        = return $ Erased@@ -579,11 +576,13 @@         | x `elem` holes || y `elem` holes = return True         | 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' _)))+    ceq ps x (Bind n (Lam t) (App _ y (V 0))) +          = ceq ps x (substV (P Bound n t) y)+    ceq ps (Bind n (Lam t) (App _ x (V 0))) y +          = ceq ps (substV (P Bound n t) 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+    ceq ps (Bind n (Lam t) (App _ x (P Bound n' _))) y         | n == n' = ceq ps x y      ceq ps (Bind n (PVar t) sc) y = ceq ps sc y@@ -605,7 +604,7 @@             ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')             ceqB ps (Pi i v t) (Pi i' 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 (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)@@ -888,11 +887,13 @@                            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' }+                                           (args_rt, sc_rt)+                           op = (CaseOp (ci { case_inlinable = inlc })+                                                ty argtys ps_in ps_tot cdef,+                                 access, Unchecked, EmptyMI)+                       in addDef n op ctxt+                    other -> error ("Error adding case def: " ++ show other)+      in uctxt { definitions = ctxt' }  -- simplify a definition for totality checking simplifyCasedef :: Name -> ErasureInfo -> Context -> Context@@ -1006,19 +1007,24 @@          _                          -> False  lookupP :: Name -> Context -> [Term]-lookupP = lookupP_all False+lookupP = lookupP_all False False -lookupP_all :: Bool -> Name -> Context -> [Term]-lookupP_all all n ctxt-   = do def <- lookupCtxt n (definitions ctxt)+lookupP_all :: Bool -> Bool -> Name -> Context -> [Term]+lookupP_all all exact n ctxt+   = do (n', def) <- names          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)+          (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 -> if all then return (fst p) else []           _      -> return (fst p)+  where+    names = let ns = lookupCtxtName n (definitions ctxt) in+                if exact +                   then filter (\ (n', d) -> n' == n) ns+                   else ns  lookupDefExact :: Name -> Context -> Maybe Def lookupDefExact n ctxt = tfst <$> lookupCtxtExact n (definitions ctxt)@@ -1084,5 +1090,5 @@ uniqueBindersCtxt ctxt ns (Bind n b sc)     = let n' = uniqueNameCtxt ctxt n ns in           Bind n' (fmap (uniqueBindersCtxt ctxt (n':ns)) b) (uniqueBindersCtxt ctxt ns sc)-uniqueBindersCtxt ctxt ns (App f a) = App (uniqueBindersCtxt ctxt ns f) (uniqueBindersCtxt ctxt ns a)+uniqueBindersCtxt ctxt ns (App s f a) = App s (uniqueBindersCtxt ctxt ns f) (uniqueBindersCtxt ctxt ns a) uniqueBindersCtxt ctxt ns t = t
src/Idris/Core/Execute.hs view
@@ -103,7 +103,7 @@                       return n' toTT (EApp e1 e2) = do e1' <- toTT e1                        e2' <- toTT e2-                       return $ App e1' e2'+                       return $ App Complete e1' e2' toTT (EType u) = return $ TType u toTT (EUType u) = return $ UType u toTT EErased = return Erased@@ -192,7 +192,7 @@ doExec env ctxt tm@(Bind n b body) = do b' <- forM b (doExec env ctxt)                                         return $                                           EBind n b' (\arg -> doExec ((n, arg):env) ctxt body)-doExec env ctxt a@(App _ _) =+doExec env ctxt a@(App _ _ _) =   do let (f, args) = unApply a      f' <- doExec env ctxt f      args' <- case f' of@@ -251,6 +251,9 @@        let restArgs = drop arity args        execApp env ctxt (mkEApp c args') restArgs +execApp env ctxt f@(EP _ n _) args +    | Just (res, rest) <- getOp n args = do r <- res+                                            execApp env ctxt r rest execApp env ctxt f@(EP _ n _) args =     do let val = lookupDef n ctxt        case val of@@ -260,9 +263,9 @@              if length args >= arity                then let args' = take arity args in                     case getOp n args' of-                      Just res -> do r <- res-                                     execApp env ctxt r (drop arity args)-                      Nothing -> return (mkEApp f args)+                      Just (res, []) -> do r <- res+                                           execApp env ctxt r (drop arity args)+                      _ -> return (mkEApp f args)                else return (mkEApp f args)          [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun              do rhs <- doExec env ctxt tm@@ -418,41 +421,47 @@ delay = sUN "Delay" force = sUN "Force" --- | 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 [_, EConstant (Str n)]+-- | Look up primitive operations in the global table and transform +-- them into ExecVal functions+getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal, [ExecVal])+getOp fn (_ : _ : x : xs) | fn == pbm = Just (return x, xs)+getOp fn (_ : EConstant (Str n) : xs)     | fn == pws =-              Just $ do execIO $ putStr n-                        return (EConstant (I 0))-getOp fn [_]+              Just (do execIO $ putStr n+                       return (EConstant (I 0)), xs)+getOp fn (_:xs)     | fn == prs =-              Just $ do line <- execIO getLine-                        return (EConstant (Str line))-getOp fn [_, EP _ fn' _, EConstant (Str n)]+              Just (do line <- execIO getLine+                       return (EConstant (Str line)), xs)+getOp fn (_ : EP _ fn' _ : EConstant (Str n) : xs)     | fn == pwf && fn' == pstdout =-              Just $ do execIO $ putStr n-                        return (EConstant (I 0))-getOp fn [_, EP _ fn' _]+              Just (do execIO $ putStr n+                       return (EConstant (I 0)), xs)+getOp fn (_ : EP _ fn' _ : xs)     | fn == prf && fn' == pstdin =-              Just $ do line <- execIO getLine-                        return (EConstant (Str line))-getOp fn [_, EHandle h, EConstant (Str n)]+              Just (do line <- execIO getLine+                       return (EConstant (Str line)), xs)+getOp fn (_ : EHandle h : EConstant (Str n) : xs)     | fn == pwf =-              Just $ do execIO $ hPutStr h n-                        return (EConstant (I 0))-getOp fn [_, EHandle h]+              Just (do execIO $ hPutStr h n+                       return (EConstant (I 0)), xs)+getOp fn (_ : EHandle h : xs)     | fn == prf =-              Just $ do contents <- execIO $ hGetLine h-                        return (EConstant (Str (contents ++ "\n")))-getOp fn [_, arg]+              Just (do contents <- execIO $ hGetLine h+                       return (EConstant (Str (contents ++ "\n"))), xs)+getOp fn (_ : arg : xs)     | fn == prf =-              Just $ execFail (Msg "Can't use prim__readFile on a raw pointer in the executor.") -getOp n args = getPrim n primitives >>= flip applyPrim args-    where getPrim :: Name -> [Prim] -> Maybe ([ExecVal] -> Maybe ExecVal)+              Just $ (execFail (Msg "Can't use prim__readFile on a raw pointer in the executor."), xs)+getOp n args = do (arity, prim) <- getPrim n primitives +                  if (length args >= arity) +                     then do res <- applyPrim prim (take arity args)+                             Just (res, drop arity args)+                     else Nothing+    where getPrim :: Name -> [Prim] -> Maybe (Int, [ExecVal] -> Maybe ExecVal)           getPrim n [] = Nothing-          getPrim n ((Prim pn _ arity def _ _) : prims) | n == pn   = Just $ execPrim def-                                                        | otherwise = getPrim n prims+          getPrim n ((Prim pn _ arity def _ _) : prims) +             | n == pn   = Just (arity, execPrim def)+             | otherwise = getPrim n prims            execPrim :: ([Const] -> Maybe Const) -> [ExecVal] -> Maybe ExecVal           execPrim f args = EConstant <$> (mapM getConst args >>= f)
src/Idris/Core/ProofState.hs view
@@ -41,6 +41,7 @@                        autos    :: [(Name, [Name])], -- ^ unsolved 'auto' implicits with their holes                        previous :: Maybe ProofState, -- ^ for undo                        context  :: Context,+                       datatypes :: Ctxt TypeInfo,                        plog     :: String,                        unifylog :: Bool,                        done     :: Bool,@@ -292,14 +293,15 @@ 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 (mkProofTerm (Bind h (Hole ty')-                           (P Bound h ty'))) ty [] (h, []) [] []-                           Nothing [] []-                           [] [] []-                           Nothing ctxt "" False False [] []+newProof :: Name -> Context -> Ctxt TypeInfo -> Type -> ProofState+newProof n ctxt datatypes ty =+  let h = holeName 0+      ty' = vToP ty+  in PS n [h] [] 1 (mkProofTerm (Bind h (Hole ty')+        (P Bound h ty'))) ty [] (h, []) [] []+        Nothing [] []+        [] [] []+        Nothing ctxt datatypes "" False False [] []  type TState = ProofState -- [TacticAction]) type RunTactic = RunTactic' TState@@ -328,7 +330,7 @@        | 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 (App s f a) = App s (cl env f) (cl env a)    cl env t = t  attack :: RunTactic@@ -551,13 +553,36 @@                             recents = x : recents ps,                             instances = instances ps \\ [x],                             dotted = dropUnified dropdots (dotted ps) })-        let tm' = subst x val sc in-            return tm'+        let (locked, did) = tryLock (holes ps \\ [x]) (updsubst x val sc) in+            return locked   where dropUnified ddots [] = []         dropUnified ddots ((x, es) : ds)              | x `elem` ddots || any (\e -> e `elem` ddots) es                   = dropUnified ddots ds              | otherwise = (x, es) : dropUnified ddots ds++        tryLock :: [Name] -> Term -> (Term, Bool)+        tryLock hs tm@(App Complete _ _) = (tm, True)+        tryLock hs tm@(App s f a) =+             let (f', fl) = tryLock hs f+                 (a', al) = tryLock hs a in+                 if fl && al then (App Complete f' a', True)+                             else (App s f' a', False)+        tryLock hs t@(P _ n _) = (t, not $ n `elem` hs)+        tryLock hs t@(Bind n (Hole _) sc) = (t, False)+        tryLock hs t@(Bind n (Guess _ _) sc) = (t, False)+        tryLock hs t@(Bind n (Let ty val) sc) +            = let (ty', tyl) = tryLock hs ty+                  (val', vall) = tryLock hs val+                  (sc', scl) = tryLock hs sc in+                  (Bind n (Let ty' val') sc', tyl && vall && scl)+        tryLock hs t@(Bind n b sc) +            = let (bt', btl) = tryLock hs (binderTy b)+                  (val', vall) = tryLock hs val+                  (sc', scl) = tryLock hs sc in+                  (Bind n (b { binderTy = bt' }) sc', btl && scl)+        tryLock hs t = (t, True)+ solve _ _ h@(Bind x t sc)    = do ps <- get         case findType x sc of@@ -581,7 +606,7 @@        (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+           Bind y (Pi _ s _) t -> let t' = updsubst y (P Bound n s) t in                                       do ns <- unify' ctxt env (s, Nothing) (tyv, Nothing)                                          ps <- get                                          let (uh, uns) = unified ps@@ -600,7 +625,7 @@                     _ -> 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+               let t' = updsubst 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."@@ -623,7 +648,7 @@                                           (notunified ps),                            injective = addInj n x (injective ps)                          })-       return $ Bind n (PVar t) (subst x (P Bound n t) sc)+       return $ Bind n (PVar t) (updsubst x (P Bound n t) sc)   where addInj n x ps | x `elem` ps = n : ps                       | otherwise = ps patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm@@ -638,7 +663,7 @@  expandLet :: Name -> Term -> RunTactic expandLet n v ctxt env tm =-       return $ subst n v tm+       return $ updsubst n v tm  rewrite :: Raw -> RunTactic rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =@@ -661,9 +686,9 @@ -- 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 (App s 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 s 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@@ -750,7 +775,7 @@                     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+           Bind y (PVTy s) t -> let t' = updsubst 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"@@ -846,6 +871,9 @@                (updateSolvedTerm ns r, fmap (updateProv ns) rp) (updateError ns e) xs sc updateError ns e = e +updateRes ns [] = []+updateRes ns ((x, t) : ts) = (x, updateSolvedTerm ns t) : updateRes ns ts+ solveInProblems x val [] = [] solveInProblems x val ((l, r, env, err) : ps)    = ((psubst x val l, psubst x val r,@@ -873,7 +901,15 @@ updateProblems :: ProofState -> [(Name, TT Name)] -> Fails                      -> ([(Name, TT Name)], Fails) -- updateProblems ctxt [] ps inj holes = ([], ps)-updateProblems ps updates probs = up updates probs where+updateProblems ps updates probs = rec 10 updates probs+ where+  -- keep trying if we make progress, but not too many times...+  rec 0 us fs = (us, fs)+  rec n us fs = case up us [] fs of+                     res@(_, []) -> res+                     res@(us', _) | length us' == length us -> res+                     (us', fs') -> rec (n - 1) us' fs'+   hs = holes ps   inj = injective ps   ctxt = context ps@@ -881,8 +917,8 @@   usupp = map fst (notunified ps)   dont = dontunify ps -  up ns [] = (ns, [])-  up ns (prob@(x, y, ready, env, err, while, um) : ps) =+  up ns acc [] = (ns, map (updateNs ns) (reverse acc))+  up ns acc (prob@(x, y, ready, env, err, while, um) : ps) =     let (x', newx) = updateSolvedTerm' ns x         (y', newy) = updateSolvedTerm' ns y         (lp, rp) = getProvenance err@@ -893,14 +929,18 @@             case unify ctxt env' (x', lp) (y', rp) inj hs usupp while of                  OK (v, []) -> traceWhen ulog ("DID " ++ show (x',y',ready,v,dont)) $                                 let v' = filter (\(n, _) -> n `notElem` dont) v in-                                    up (ns ++ v') ps+                                    up (ns ++ v') acc ps                  e -> -- trace ("FAILED " ++ show (x',y',ready,e)) $-                       let (ns', ps') = up ns ps in-                           (ns', (x',y', False, env',err', while, um) : ps')+                      up ns ((x',y',False,env',err',while,um) : acc) ps             else -- trace ("SKIPPING " ++ show (x,y,ready)) $-                 let (ns', ps') = up ns ps in-                     (ns', (x',y', False, env',err', while, um) : ps')+                 up ns ((x',y', False, env',err', while, um) : acc) ps +  updateNs ns (x, y, t, env, err, fc, fa)+       = let (x', newx) = updateSolvedTerm' ns x+             (y', newy) = updateSolvedTerm' ns y in+             (x', y', newx || newy, +                  updateEnv ns env, updateError ns err, fc, fa)+ -- attempt to solve remaining problems with match_unify matchProblems :: Bool -> ProofState -> [(Name, TT Name)] -> Fails                      -> ([(Name, TT Name)], Fails)@@ -970,7 +1010,9 @@                        previous = Just ps, plog = "",                        notunified = updateNotunified ns' (notunified ps),                        recents = recents ps ++ map fst ns',+                       dotted = filter (notIn ns') (dotted ps),                        holes = holes ps \\ (map fst ns') }, plog ps)+   where notIn ns (h, _) = h `notElem` map fst ns processTactic (MatchProblems all) ps     = do let (ns', probs') = matchProblems all ps [] (problems ps)              (ns'', probs'') = matchProblems all ps ns' probs'@@ -997,14 +1039,16 @@                      let pterm'' = updateSolved ns' (pterm ps')                      traceWhen (unifylog ps)                                   ("Updated problems after solve " ++ qshow probs' ++ "\n" ++-                                  "(Toplevel) Dropping holes: " ++ show (map fst ns')) $+                                  "(Toplevel) Dropping holes: " ++ show (map fst ns') ++ "\n" +++                                  "Holes were: " ++ show (holes ps')) $                        return (ps' { pterm = pterm'',                                      solved = Nothing,                                      problems = probs',                                      notunified = updateNotunified ns' (notunified ps'),                                      previous = Just ps, plog = "",                                      recents = recents ps' ++ map fst ns',-                                     holes = holes ps' \\ (map fst ns')}, plog ps')+                                     holes = holes ps' \\ (map fst ns')+                                   }, plog ps')  process :: Tactic -> Name -> StateT TState TC () process EndUnify _
src/Idris/Core/ProofTerm.hs view
@@ -7,7 +7,7 @@  module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm,                             updateSolved, updateSolvedTerm, updateSolvedTerm',-                            bound_in, bound_in_term, refocus,+                            bound_in, bound_in_term, refocus, updsubst,                             Hole, RunTactic',                             goal, atHole) where @@ -21,8 +21,8 @@  -- | A zipper over terms, in order to efficiently update proof terms. data TermPath = Top-              | AppL TermPath Term-              | AppR Term TermPath+              | AppL (AppStatus Name) TermPath Term+              | AppR (AppStatus Name) Term TermPath               | InBind Name BinderPath Term               | InScope Name (Binder Term) TermPath   deriving Show@@ -39,8 +39,8 @@ -- words, "graft" one term path into another. replaceTop :: TermPath -> TermPath -> TermPath replaceTop p Top = p-replaceTop p (AppL l t) = AppL (replaceTop p l) t-replaceTop p (AppR t r) = AppR t (replaceTop p r)+replaceTop p (AppL s l t) = AppL s (replaceTop p l) t+replaceTop p (AppR s t r) = AppR s t (replaceTop p r) replaceTop p (InBind n bp sc) = InBind n (replaceTopB p bp) sc   where     replaceTopB p (Binder b) = Binder (fmap (replaceTop p) b)@@ -53,8 +53,8 @@ -- | Build a term from a zipper, given something to put in the hole. rebuildTerm :: Term -> TermPath -> Term rebuildTerm tm Top = tm-rebuildTerm tm (AppL p a) = App (rebuildTerm tm p) a-rebuildTerm tm (AppR f p) = App f (rebuildTerm tm p)+rebuildTerm tm (AppL s p a) = App s (rebuildTerm tm p) a+rebuildTerm tm (AppR s f p) = App s f (rebuildTerm tm p) rebuildTerm tm (InScope n b p) = Bind n b (rebuildTerm tm p) rebuildTerm tm (InBind n bp sc) = Bind n (rebuildBinder tm bp) sc @@ -73,9 +73,10 @@ findHole n env t = fh' env Top t where   fh' env path tm@(Bind x h sc)        | hole h && n == x = Just (path, env, tm)-  fh' env path (App f a)-      | Just (p, env', tm) <- fh' env path a = Just (AppR f p, env', tm)-      | Just (p, env', tm) <- fh' env path f = Just (AppL p a, env', tm)+  fh' env path (App Complete _ _) = Nothing+  fh' env path (App s f a)+      | Just (p, env', tm) <- fh' env path a = Just (AppR s f p, env', tm)+      | Just (p, env', tm) <- fh' env path f = Just (AppL s p a, env', tm)   fh' env path (Bind x b sc)       | Just (bp, env', tm) <- fhB env path b = Just (InBind x bp sc, env', tm)       | Just (p, env', tm) <- fh' ((x,b):env) path sc = Just (InScope x b p, env', tm)@@ -112,7 +113,7 @@       -- First look for the hole in the proof term as-is       | Just (p', env', tm') <- findHole n env tm              = PT (replaceTop p' path) env' tm' ups-      -- Next apply the updates, and look for the hole in the resulting term+      -- If it's not there, rebuild and look from the top        | Just (p', env', tm') <- findHole n [] (rebuildTerm tm (updateSolvedPath ups path))              = PT p' env' tm' []       | otherwise = pt@@ -156,19 +157,20 @@     updateSolved' xs (Bind n (Hole ty) t)         | Just v <- lookup n xs             = case xs of-                   [_] -> (subst n v t, True) -- some may be Vs! Can't assume+                   [_] -> (updsubst n v t, True) -- some may be Vs! Can't assume                                               -- explicit names                    _ -> let (t', _) = updateSolved' xs t in-                            (subst n v t', True)+                            (updsubst n v t', True)     updateSolved' xs tm@(Bind n b t)         | otherwise = let (t', ut) = updateSolved' xs t                           (b', ub) = updateSolvedB' xs b in                           if ut || ub then (Bind n b' t', True)                                       else (tm, False)-    updateSolved' xs t@(App f a)+    updateSolved' xs t@(App Complete f a) = (t, False)+    updateSolved' xs t@(App s f a)         = let (f', uf) = updateSolved' xs f               (a', ua) = updateSolved' xs a in-              if uf || ua then (App f' a', True)+              if uf || ua then (App s f' a', True)                           else (t, False)     updateSolved' xs t@(P _ n@(MN _ _) _)         | Just v <- lookup n xs = (v, True)@@ -189,7 +191,7 @@                               if u then (b { binderTy = ty' }, u) else (b, False)      noneOf ns (P _ n _) | n `elem` ns = False-    noneOf ns (App f a) = noneOf ns a && noneOf ns f+    noneOf ns (App s f a) = noneOf ns a && noneOf ns f     noneOf ns (Bind n (Hole ty) t) = n `notElem` ns && noneOf ns ty && noneOf ns t     noneOf ns (Bind n b t) = noneOf ns t && noneOfB ns b       where@@ -198,6 +200,49 @@         noneOfB ns b = noneOf ns (binderTy b)     noneOf ns _ = True +-- | As 'subst', in TT, but takes advantage of knowing not to substitute+-- under Complete applications.+updsubst :: 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)+updsubst n v tm = fst $ subst' 0 tm+  where+    -- keep track of updates to save allocations - this is a big win on+    -- large terms in particular+    -- ('Maybe' would be neater here, but >>= is not the right combinator.+    -- Feel free to tidy up, as long as it still saves allocating when no+    -- substitution happens...)+    subst' i (V x) | i == x = (v, True)+    subst' i (P _ x _) | n == x = (v, True)+    subst' i t@(P nt x ty)+         = let (ty', ut) = subst' i ty in+               if ut then (P nt x ty', True) else (t, False)+    subst' i t@(Bind x b sc) | x /= n+         = let (b', ub) = substB' i b+               (sc', usc) = subst' (i+1) sc in+               if ub || usc then (Bind x b' sc', True) else (t, False)+    subst' i t@(App Complete f a) = (t, False)+    subst' i t@(App s f a) = let (f', uf) = subst' i f+                                 (a', ua) = subst' i a in+                                 if uf || ua then (App s f' a', True) else (t, False)+    subst' i t@(Proj x idx) = let (x', u) = subst' i x in+                                  if u then (Proj x' idx, u) else (t, False)+    subst' i t = (t, False)++    substB' i b@(Let t v) = let (t', ut) = subst' i t+                                (v', uv) = subst' i v in+                                if ut || uv then (Let t' v', True)+                                            else (b, False)+    substB' i b@(Guess t v) = let (t', ut) = subst' i t+                                  (v', uv) = subst' i v in+                                  if ut || uv then (Guess t' v', True)+                                              else (b, False)+    substB' i b = let (ty', u) = subst' i (binderTy b) in+                      if u then (b { binderTy = ty' }, u) else (b, False)++ -- | Apply solutions to an environment. updateEnv :: [(Name, Term)] -> Env -> Env updateEnv [] e = e@@ -208,8 +253,10 @@ updateSolvedPath :: [(Name, Term)] -> TermPath -> TermPath updateSolvedPath [] t = t updateSolvedPath ns Top = Top-updateSolvedPath ns (AppL p r) = AppL (updateSolvedPath ns p) (updateSolvedTerm ns r)-updateSolvedPath ns (AppR l p) = AppR (updateSolvedTerm ns l) (updateSolvedPath ns p)+updateSolvedPath ns t@(AppL Complete _ _) = t+updateSolvedPath ns t@(AppR Complete _ _) = t+updateSolvedPath ns (AppL s p r) = AppL s (updateSolvedPath ns p) (updateSolvedTerm ns r)+updateSolvedPath ns (AppR s l p) = AppR s (updateSolvedTerm ns l) (updateSolvedPath ns p) updateSolvedPath ns (InBind n b sc)      = InBind n (updateSolvedPathB b) (updateSolvedTerm ns sc)   where@@ -246,7 +293,8 @@     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 a `mplus` g env f+    g env (App Complete f a) = fail "Can't find hole" +    g env (App _ f a) = g env a `mplus` g env f     g env t           = fail "Can't find hole"      gb env (Let t v) = g env v `mplus` g env t@@ -291,7 +339,7 @@                  if u then return (Bind n b sc', True)                       else do (b', u) <- atHb f c env b                               return (Bind n b' sc', u)-    atH tac c env (App f a)    = ulift2 tac c env App f a+    atH tac c env (App s f a)  = ulift2 tac c env (App s) f a     atH tac c env t            = return (t, False)      atHb f c env (Let t v)   = ulift2 f c env Let t v@@ -308,6 +356,6 @@     bi (Let t v) = bound_in_term t ++ bound_in_term v     bi (Guess t v) = bound_in_term t ++ bound_in_term v     bi b = bound_in_term (binderTy b)-bound_in_term (App f a) = bound_in_term f ++ bound_in_term a+bound_in_term (App _ f a) = bound_in_term f ++ bound_in_term a bound_in_term _ = []
src/Idris/Core/TT.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor, DeriveDataTypeable #-}-+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-| TT is the core language of Idris. The language has:     * Full dependent types@@ -49,12 +49,60 @@   deriving Eq  -- | Source location. These are typically produced by the parser 'Idris.Parser.getFC'-data FC = FC { fc_fname :: String, -- ^ Filename-               fc_start :: (Int, Int), -- ^ Line and column numbers for the start of the location span-               fc_end :: (Int, Int) -- ^ Line and column numbers for the end of the location span+data FC = FC { _fc_fname :: String, -- ^ Filename+               _fc_start :: (Int, Int), -- ^ Line and column numbers for the start of the location span+               _fc_end :: (Int, Int) -- ^ Line and column numbers for the end of the location span              }-  deriving (Data, Typeable, Ord)             +        | NoFC -- ^ Locations for machine-generated terms+        | FileFC { _fc_fname :: String } -- ^ Locations with file only+  deriving (Data, Typeable, Ord) +-- TODO: find uses and destroy them, doing this case analysis at call sites+-- | Give a notion of filename associated with an FC+fc_fname :: FC -> String+fc_fname (FC f _ _) = f+fc_fname NoFC = "(no file)"+fc_fname (FileFC f) = f++-- TODO: find uses and destroy them, doing this case analysis at call sites+-- | Give a notion of start location associated with an FC+fc_start :: FC -> (Int, Int)+fc_start (FC _ start _) = start+fc_start NoFC = (0, 0)+fc_start (FileFC f) = (0, 0)++-- TODO: find uses and destroy them, doing this case analysis at call sites+-- | Give a notion of end location associated with an FC+fc_end :: FC -> (Int, Int)+fc_end (FC _ _ end) = end+fc_end NoFC = (0, 0)+fc_end (FileFC f) = (0, 0)++-- | Get the largest span containing the two FCs+spanFC :: FC -> FC -> FC+spanFC (FC f start end) (FC f' start' end')+    | f == f' = FC f (minLocation start start') (maxLocation end end')+    | otherwise = NoFC+  where minLocation (l, c) (l', c') =+          case compare l l' of+            LT -> (l, c)+            EQ -> (l, min c c')+            GT -> (l', c')+        maxLocation (l, c) (l', c') =+          case compare l l' of+            LT -> (l', c')+            EQ -> (l, max c c')+            GT -> (l, c)+spanFC fc@(FC f _ _) (FileFC f') | f == f' = fc+                                 | otherwise = NoFC+spanFC (FileFC f') fc@(FC f _ _) | f == f' = fc+                                 | otherwise = NoFC+spanFC (FileFC f) (FileFC f') | f == f' = FileFC f+                              | otherwise = NoFC+spanFC NoFC fc = fc+spanFC fc NoFC = fc++ -- | Ignore source location equality (so deriving classes do not compare FCs) instance Eq FC where   _ == _ = True@@ -65,14 +113,17 @@ instance Eq FC' where   FC' fc == FC' fc' = fcEq fc fc'     where fcEq (FC n s e) (FC n' s' e') = n == n' && s == s' && e == e'+          fcEq NoFC NoFC = True+          fcEq (FileFC f) (FileFC f') = f == f'+          fcEq _ _ = False  -- | Empty source location emptyFC :: FC-emptyFC = fileFC ""+emptyFC = NoFC --- | Source location with file only+-- | Source location with file only fileFC :: String -> FC-fileFC s = FC s (0, 0) (0, 0)+fileFC s = FileFC s  {-! deriving instance Binary FC@@ -81,18 +132,22 @@  instance Sized FC where   size (FC f s e) = 4 + length f+  size NoFC = 1+  size (FileFC f) = length f  instance Show FC where     show (FC f s e) = f ++ ":" ++ showLC s e       where showLC (sl, sc) (el, ec) | sl == el && sc == ec = show sl ++ ":" ++ show sc                                      | sl == el             = show sl ++ ":" ++ show sc ++ "-" ++ show ec                                      | otherwise            = show sl ++ ":" ++ show sc ++ "-" ++ show el ++ ":" ++ show ec+    show NoFC = "No location"+    show (FileFC f) = f  -- | Output annotation for pretty-printed name - decides colour-data NameOutput = TypeOutput | FunOutput | DataOutput | MetavarOutput | PostulateOutput+data NameOutput = TypeOutput | FunOutput | DataOutput | MetavarOutput | PostulateOutput deriving Show  -- | Text formatting output-data TextFormatting = BoldText | ItalicText | UnderlineText+data TextFormatting = BoldText | ItalicText | UnderlineText deriving Show  -- | Output annotations for pretty-printing data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe String) (Maybe String)@@ -108,6 +163,14 @@                       | AnnTerm [(Name, Bool)] (TT Name) -- ^ pprint bound vars, original term                       | AnnSearchResult Ordering -- ^ more general, isomorphic, or more specific                       | AnnErr Err+                      | AnnNamespace [T.Text] (Maybe FilePath)+                        -- ^ A namespace (e.g. on an import line or in+                        -- a namespace declaration). Stored starting+                        -- at the root, with the hierarchy fully+                        -- resolved. If a file path is present, then+                        -- the namespace represents a module imported+                        -- from that file.+  deriving Show  -- | Used for error reflection data ErrorReportPart = TextPart String@@ -117,9 +180,6 @@                        deriving (Show, Eq, Data, Typeable)  --- Please remember to keep Err synchronised with--- Language.Reflection.Errors.Err in the stdlib!- data Provenance = ExpectedType                 | TooManyArgs Term                 | InferredVal@@ -131,6 +191,10 @@ deriving instance Binary Err !-} ++-- NB: 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@@ -161,7 +225,8 @@           | CantResolveAlts [Name]           | IncompleteTerm t           | NoEliminator String t-          | UniverseError+          | UniverseError FC UExp (Int, Int) (Int, Int) [ConstraintFC]+            -- ^ Location, bad universe, old domain, new domain, suspects           | UniqueError Universe Name           | UniqueKindError Universe Name           | ProgramLineComment@@ -178,8 +243,9 @@           | LoadingFailed String (Err' t)           | ReflectionError [[ErrorReportPart]] (Err' t)           | ReflectionFailed String (Err' t)-          | ElabDebug (Maybe String) t [(Name, t, [(Name, Binder t)])]+          | ElabScriptDebug (Maybe String) t [(Name, t, [(Name, Binder t)])]             -- ^ User-specified message, proof term, goals with context (first goal is focused)+          | ElabScriptStuck t   deriving (Eq, Functor, Data, Typeable)  type Err = Err' Term@@ -238,7 +304,6 @@   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@@ -365,6 +430,7 @@                  | CaseN Name                  | ElimN Name                  | InstanceCtorN Name+                 | MetaN Name Name   deriving (Eq, Ord, Data, Typeable) {-! deriving instance Binary SpecialName@@ -389,6 +455,9 @@   pretty n@(MN i s) = annotate (AnnName n Nothing Nothing Nothing) $                       lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace   pretty n@(SN s) = annotate (AnnName n Nothing Nothing Nothing) $ text (show s)+  pretty n@(SymRef i) = annotate (AnnName n Nothing Nothing Nothing) $+                        text $ "##symbol" ++ show i ++ "##"+  pretty NErased = annotate (AnnName NErased Nothing Nothing Nothing) $ text "_"  instance Pretty [Name] OutputAnnotation where   pretty = encloseSep empty empty comma . map pretty@@ -399,6 +468,7 @@     show (MN _ u) | u == txt "underscore" = "_"     show (MN i s) = "{" ++ str s ++ show i ++ "}"     show (SN s) = show s+    show (SymRef i) = "##symbol" ++ show i ++ "##"     show NErased = "_"  instance Show SpecialName where@@ -410,6 +480,7 @@     show (CaseN n) = "case block in " ++ show n     show (ElimN n) = "<<" ++ show n ++ " eliminator>>"     show (InstanceCtorN n) = "constructor of " ++ show n+    show (MetaN parent meta) = "<<" ++ show parent ++ " " ++ show meta ++ ">>"  -- Show a name in a way decorated for code generation, not human reading showCG :: Name -> String@@ -425,6 +496,9 @@         showCG' (ParentN p c) = showCG p ++ "#" ++ show c         showCG' (CaseN c) = showCG c ++ "_case"         showCG' (ElimN sn) = showCG sn ++ "_elim"+        showCG' (InstanceCtorN n) = showCG n ++ "_ictor"+        showCG' (MetaN parent meta) = showCG parent ++ "_meta_" ++ showCG meta+showCG (SymRef i) = error "can't do codegen for a symbol reference" showCG NErased = "_"  @@ -524,7 +598,6 @@     pretty IT64 = text "Bits64"  data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar-           | ITVec NativeTy Int     deriving (Show, Eq, Ord, Data, Typeable)  intTyName :: IntTy -> String@@ -532,7 +605,6 @@ 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 https://github.com/idris-lang/Idris-dev/issues/1723     deriving (Show, Eq, Ord, Data, Typeable)@@ -547,7 +619,6 @@     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@@ -565,11 +636,9 @@  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            | WorldType | TheWorld-           | PtrType | ManagedPtrType | BufferType | VoidType | Forgot+           | VoidType | Forgot   deriving (Eq, Ord, Data, Typeable) {-! deriving instance Binary Const@@ -579,10 +648,7 @@ isTypeConst :: Const -> Bool isTypeConst (AType _) = True isTypeConst StrType = True-isTypeConst ManagedPtrType = True-isTypeConst BufferType = True isTypeConst WorldType = True-isTypeConst PtrType = True isTypeConst VoidType = True isTypeConst _ = False @@ -599,9 +665,6 @@   pretty StrType = text "String"   pretty TheWorld = text "%theWorld"   pretty WorldType = text "prim__World"-  pretty BufferType = text "prim__UnsafeBuffer"-  pretty PtrType = text "Ptr"-  pretty ManagedPtrType = text "Ptr"   pretty VoidType = text "Void"   pretty Forgot = text "Forgot"   pretty (B8 w) = text . show $ w@@ -620,10 +683,6 @@ constIsType (B16 _) = False constIsType (B32 _) = False constIsType (B64 _) = False-constIsType (B8V _) = False-constIsType (B16V _) = False-constIsType (B32V _) = False-constIsType (B64V _) = False constIsType _ = True  -- | Get the docstring for a Const@@ -633,17 +692,10 @@ constDocs c@(AType (ATInt ITChar))         = "Characters in some unspecified encoding" constDocs c@(AType ATFloat)                = "Double-precision floating-point numbers" constDocs StrType                          = "Strings in some unspecified encoding"-constDocs PtrType                          = "Foreign pointers"-constDocs ManagedPtrType                   = "Managed pointers"-constDocs BufferType                       = "Copy-on-write buffers" constDocs c@(AType (ATInt (ITFixed IT8)))  = "Eight bits (unsigned)" constDocs c@(AType (ATInt (ITFixed IT16))) = "Sixteen bits (unsigned)" constDocs c@(AType (ATInt (ITFixed IT32))) = "Thirty-two bits (unsigned)" constDocs c@(AType (ATInt (ITFixed IT64))) = "Sixty-four bits (unsigned)"-constDocs c@(AType (ATInt (ITVec IT8 16))) = "Vectors of sixteen eight-bit values"-constDocs c@(AType (ATInt (ITVec IT16 8))) = "Vectors of eight sixteen-bit values"-constDocs c@(AType (ATInt (ITVec IT32 4))) = "Vectors of four thirty-two-bit values"-constDocs c@(AType (ATInt (ITVec IT64 2))) = "Vectors of two sixty-four-bit values" constDocs (Fl f)                           = "A float" constDocs (I i)                            = "A fixed-precision integer" constDocs (BI i)                           = "An arbitrary-precision integer"@@ -657,10 +709,6 @@                                              showIntAtBase 16 intToDigit w "" constDocs (B64 w)                          = "The sixty-four-bit value 0x" ++                                              showIntAtBase 16 intToDigit w ""-constDocs (B8V v)                          = "A vector of eight-bit values"-constDocs (B16V v)                         = "A vector of sixteen-bit values"-constDocs (B32V v)                         = "A vector of thirty-two-bit values"-constDocs (B64V v)                         = "A vector of sixty-four-bit values" constDocs prim                             = "Undocumented"  data Universe = NullType | UniqueType | AllTypes@@ -669,7 +717,7 @@ instance Show Universe where     show UniqueType = "UniqueType"     show NullType = "NullType"-    show AllTypes = "Type*"+    show AllTypes = "AnyType"  data Raw = Var Name          | RBind Name (Binder Raw) Raw@@ -791,11 +839,11 @@ -- | Universe constraints data UConstraint = ULT UExp UExp -- ^ Strictly less than                  | ULE UExp UExp -- ^ Less than or equal to-  deriving (Eq, Ord)+  deriving (Eq, Ord, Data, Typeable)  data ConstraintFC = ConstraintFC { uconstraint :: UConstraint,                                    ufc :: FC }-  deriving Show+  deriving (Show, Data, Typeable)  instance Eq ConstraintFC where     x == y = uconstraint x == uconstraint y  @@ -832,6 +880,11 @@     TCon _ a == TCon _ b = (a == b) -- ignore tag     _        == _        = False +data AppStatus n = Complete+                 | MaybeHoles+                 | Holes [n]+    deriving (Eq, Ord, Functor, Data, Typeable, Show)+ -- | 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'@.@@ -840,7 +893,7 @@             -- 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+          | App (AppStatus n) !(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'@@ -876,18 +929,24 @@     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 (App _ f a) = termsize n f + termsize n a     termsize n (Proj t i) = termsize n t     termsize n _ = 1 +instance Sized Universe where+  size u = 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 (App _ l r) = 1 + size l + size r   size (Constant c) = size c   size Erased = 1   size (TType u) = 1 + size u+  size (Proj a _) = 1 + size a+  size Impossible = 1+  size (UType u) = 1 + size u  instance Pretty a o => Pretty (TT a) o where   pretty _ = text "test"@@ -901,12 +960,32 @@                          d_cons     :: [(n, TT n)] }   deriving (Show, Functor, Eq) +-- | 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+             | DefaultCaseFun -- ^ Set if a case function should be generated for data type+             | DataErrRev+    deriving (Show, Eq)++type DataOpts = [DataOpt]++data TypeInfo = TI { con_names :: [Name],+                     codata :: Bool,+                     data_opts :: DataOpts,+                     param_pos :: [Int],+                     mutual_types :: [Name] }+    deriving Show+{-!+deriving instance Binary TypeInfo+deriving instance NFData TypeInfo+!-}+ 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+    (==) (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@@ -922,15 +1001,15 @@ isInjective (P (DCon _ _ _) _ _) = True isInjective (P (TCon _ _) _ _) = True isInjective (Constant _)       = True-isInjective (TType x)            = True+isInjective (TType x)          = True isInjective (Bind _ (Pi _ _ _) sc) = True-isInjective (App f a)          = isInjective f+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 (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@@ -942,7 +1021,7 @@     subst i (P nt x ty) = P nt x (subst i ty)     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 (App s f a) = App s (subst i f) (subst i a)     subst i (Proj x idx) = Proj (subst i x) idx     subst i t = t @@ -951,11 +1030,11 @@ -- that has been substituted. substV :: TT n -> TT n -> TT n substV x tm = dropV 0 (instantiate x tm) where-    subst i (P nt x ty) = P nt x (subst i ty)+    dropV i (P nt x ty) = P nt x (dropV i ty)     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 (App s f a) = App s (dropV i f) (dropV i a)     dropV i (Proj x idx) = Proj (dropV i x) idx     dropV i t = t @@ -966,7 +1045,7 @@                                   Bind x b'                                      (explicitNames (instantiate                                         (P Bound x (binderTy b')) sc))-explicitNames (App f a) = App (explicitNames f) (explicitNames a)+explicitNames (App s f a) = App s (explicitNames f) (explicitNames a) explicitNames (Proj x idx) = Proj (explicitNames x) idx explicitNames t = t @@ -980,7 +1059,7 @@ -- 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 (App s f a) = App s (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 @@ -991,7 +1070,7 @@      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 (App s f a) = App s (ab top f) (ab top a)      ab top (Proj t idx) = Proj (ab top t) idx      ab top t = t @@ -1010,14 +1089,14 @@                           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 (App s f a) = App s (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 (App s f a) = App s (finalise f) (finalise a) finalise t = t  -- Once we've finished checking everything about a term we no longer need@@ -1025,7 +1104,7 @@  pEraseType :: TT n -> TT n pEraseType (P nt t _) = P nt t Erased-pEraseType (App f a) = App (pEraseType f) (pEraseType a)+pEraseType (App s f a) = App s (pEraseType f) (pEraseType a) pEraseType (Bind n b sc) = Bind n (fmap pEraseType b) (pEraseType sc) pEraseType t = t @@ -1052,9 +1131,9 @@          = let (b', ub) = substB' i b                (sc', usc) = subst' (i+1) sc in                if ub || usc then (Bind x b' sc', True) else (t, False)-    subst' i t@(App f a) = let (f', uf) = subst' i f-                               (a', ua) = subst' i a in-                               if uf || ua then (App f' a', True) else (t, False)+    subst' i t@(App s f a) = let (f', uf) = subst' i f+                                 (a', ua) = subst' i a in+                                 if uf || ua then (App s f' a', True) else (t, False)     subst' i t@(Proj x idx) = let (x', u) = subst' i x in                                   if u then (Proj x' idx, u) else (t, False)     subst' i t = (t, False)@@ -1079,7 +1158,7 @@    s' i (P _ x _) | n == x = v    s' i (Bind x b sc) | n == x = Bind x (fmap (s' i) b) sc                       | otherwise = Bind x (fmap (s' i) b) (s' (i+1) sc)-   s' i (App f a) = App (s' i f) (s' i a)+   s' i (App st f a) = App st (s' i f) (s' i a)    s' i (Proj t idx) = Proj (s' i t) idx    s' i t = t @@ -1097,7 +1176,7 @@              -> TT n substTerm old new = st where   st t | t == old = new-  st (App f a) = App (st f) (st a)+  st (App s f a) = App s (st f) (st a)   st (Bind x b sc) = Bind x (fmap st b) (st sc)   st t = t @@ -1111,7 +1190,7 @@        where noB' i (Let t v) = do no' i t; no' i v              noB' i (Guess t v) = do no' i t; no' i v              noB' i b = no' i (binderTy b)-    no' i (App f a) = do no' i f; no' i a+    no' i (App _ f a) = do no' i f; no' i a     no' i (Proj x _) = no' i x     no' i _ = return () @@ -1125,7 +1204,7 @@        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 (App _ f a) = no' i f && no' i a     no' i (Proj x _) = no' i x     no' i _ = True @@ -1137,7 +1216,7 @@     freeNames' (Bind n (Let t v) sc) = freeNames' v ++ (freeNames' sc \\ [n])                                             ++ freeNames' t     freeNames' (Bind n b sc) = freeNames' (binderTy b) ++ (freeNames' sc \\ [n])-    freeNames' (App f a) = freeNames' f ++ freeNames' a+    freeNames' (App _ f a) = freeNames' f ++ freeNames' a     freeNames' (Proj x i) = freeNames' x     freeNames' _ = [] @@ -1149,14 +1228,14 @@ -- | 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 (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+mkApp f (a:as) = mkApp (App MaybeHoles f a) as  unList :: Term -> Maybe [Term] unList tm = case unApply tm of@@ -1185,23 +1264,25 @@ safeForgetEnv :: [Name] -> TT Name -> Maybe Raw safeForgetEnv env (P _ n _) = Just $ Var n safeForgetEnv env (V i) | i < length env = Just $ Var (env !! i)-                        | otherwise = Nothing -safeForgetEnv env (Bind n b sc) +                        | otherwise = Nothing+safeForgetEnv env (Bind n b sc)      = do let n' = uniqueName n env           b' <- safeForgetEnvB env b           sc' <- safeForgetEnv (n':env) sc           Just $ RBind n' b' sc'-  where safeForgetEnvB env (Let t v) = liftM2 Let (safeForgetEnv env t) +  where safeForgetEnvB env (Let t v) = liftM2 Let (safeForgetEnv env t)                                                   (safeForgetEnv env v)-        safeForgetEnvB env (Guess t v) = liftM2 Guess (safeForgetEnv env t) +        safeForgetEnvB env (Guess t v) = liftM2 Guess (safeForgetEnv env t)                                                       (safeForgetEnv env v)         safeForgetEnvB env b = do ty' <- safeForgetEnv env (binderTy b)-                                  Just $ fmap (\_ -> ty') b -safeForgetEnv env (App f a) = liftM2 RApp (safeForgetEnv env f) (safeForgetEnv env a)+                                  Just $ fmap (\_ -> ty') b+safeForgetEnv env (App _ f a) = liftM2 RApp (safeForgetEnv env f) (safeForgetEnv env a) safeForgetEnv env (Constant c) = Just $ RConstant c safeForgetEnv env (TType i) = Just RType safeForgetEnv env (UType u) = Just $ RUType u safeForgetEnv env Erased    = Just $ RConstant Forgot+safeForgetEnv env (Proj tm i) = error "Don't know how to forget a projection"+safeForgetEnv env Impossible = error "Don't know how to forget Impossible"  -- | Introduce a 'Bind' into the given term for each element of the -- given list of (name, binder) pairs.@@ -1250,10 +1331,11 @@         = let n' = uniqueNameSet n ns               ns' = insert n' ns in               Bind n' (fmap (ubSet ns') b) (ubSet ns' sc)-    ubSet ns (App f a) = App (ubSet ns f) (ubSet ns a)+    ubSet ns (App s f a) = App s (ubSet ns f) (ubSet ns a)     ubSet ns t = t  +nextName :: Name -> Name 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)@@ -1273,6 +1355,9 @@     nextName' (ElimN n) = ElimN (nextName n)     nextName' (MethodN n) = MethodN (nextName n)     nextName' (InstanceCtorN n) = InstanceCtorN (nextName n)+    nextName' (MetaN parent meta) = MetaN parent (nextName meta)+nextName NErased = NErased+nextName (SymRef i) = error "Can't generate a name from a symbol reference"  type Term = TT Name type Type = Term@@ -1303,28 +1388,22 @@     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 ATFloat) = "Double"     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 TheWorld = "prim__TheWorld"     show WorldType = "prim__WorldType"     show StrType = "String"-    show BufferType = "prim__UnsafeBuffer"-    show PtrType = "Ptr"-    show ManagedPtrType = "ManagedPtr"     show VoidType = "Void"+    show Forgot = "Forgot"  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 -> Term -> Doc OutputAnnotation prettyEnv env t = prettyEnv' env t False   where     prettyEnv' env t dbg = prettySe 10 env t dbg@@ -1351,21 +1430,25 @@           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 =+    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)+    prettySe p env Impossible debug = text "Impossible"+    prettySe p env (UType u) debug = text (show u)      -- 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 (GHole _ t) = prettyB env "?gdefer" "." 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 (NLet t v) = prettyBv env "nlet" "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@@ -1395,7 +1478,7 @@        where arrow (TType _) = " -> "              arrow u = " [" ++ show u ++ "] -> "     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 (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 = "[__]"@@ -1411,6 +1494,7 @@     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 (NLet t v)   = showbv env "nlet " " 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@@ -1420,9 +1504,9 @@     bracket outer inner str | inner > outer = "(" ++ str ++ ")"                             | otherwise = str --- | Check whether a term has any holes in it - impure if so+-- | Check whether a term has any hole bindings in it - impure if so pureTerm :: TT Name -> Bool-pureTerm (App f a) = pureTerm f && pureTerm a+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@@ -1438,7 +1522,7 @@ 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 (App s f a)   = App s (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@@ -1463,7 +1547,7 @@ orderPats :: Term -> Term orderPats tm = op [] tm   where-    op [] (App f a) = App f (op [] a) -- for Infer terms+    op [] (App s f a) = App s f (op [] a) -- for Infer terms      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@@ -1488,7 +1572,7 @@   where nb (Let   t v) = nub (refsIn t) ++ nub (refsIn v)         nb (Guess t v) = nub (refsIn t) ++ nub (refsIn v)         nb t = refsIn (binderTy t)-refsIn (App f a) = nub (refsIn f ++ refsIn a)+refsIn (App s f a) = nub (refsIn f ++ refsIn a) refsIn _ = []  -- Make sure all the pattern bindings are as far out as possible@@ -1525,9 +1609,9 @@                                       return (Bind n (Hole t') sc')  -    getPats (App f a) = do f' <- getPats f-                           a' <- getPats a-                           return (App f' a')+    getPats (App s f a) = do f' <- getPats f+                             a' <- getPats a+                             return (App s f' a')     getPats t = return t  allTTNames :: Eq n => TT n -> [n]@@ -1537,7 +1621,7 @@           where nb (Let   t v) = allNamesIn t ++ allNamesIn v                 nb (Guess t v) = allNamesIn t ++ allNamesIn v                 nb t = allNamesIn (binderTy t)-        allNamesIn (App f a) = allNamesIn f ++ allNamesIn a+        allNamesIn (App _ f a) = allNamesIn f ++ allNamesIn a         allNamesIn _ = []  @@ -1560,7 +1644,7 @@        | otherwise        = text ("{{{V" ++ show i ++ "}}}")     pp p bound (Bind n b sc) = ppb p bound n b $                                pp startPrec (n:bound) sc-    pp p bound (App tm1 tm2) =+    pp p bound (App _ tm1 tm2) =       bracket p appPrec . group . hang 2 $         pp appPrec bound tm1 <> line <>         pp (appPrec + 1) bound tm2
src/Idris/Core/Typecheck.hs view
@@ -77,14 +77,20 @@   smaller _        (UType u) = UType u   smaller x        _         = x +  astate | holes = MaybeHoles+         | otherwise = Complete+   chk :: Type -> -- uniqueness level          Env -> Raw -> StateT UCs TC (Term, Type)   chk u env (Var n)       | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty)       -- If we're elaborating, we don't want the private names; if we're       -- checking an already elaborated term, we do-      | (P nt n' ty : _) <- lookupP_all (not holes) n ctxt -           = return (P nt n' ty, ty)+      | [P nt n' ty] <- lookupP_all (not holes) False n ctxt +             = return (P nt n' ty, ty)+      -- If the names are ambiguous, require it to be fully qualified+      | [P nt n' ty] <- lookupP_all (not holes) True n ctxt +             = return (P nt n' ty, ty)       | otherwise = do lift $ tfail $ NoSuchVariable n   chk u env ap@(RApp f RType) | not holes     -- special case to reduce constraintss@@ -101,13 +107,13 @@                   put (v+1, ULT (UVar v) v' : cs)                   let apty = simplify initContext env                                  (Bind x (Let (TType v') (TType (UVar v))) t)-                  return (App fv (TType (UVar v)), apty)+                  return (App Complete fv (TType (UVar v)), apty)              Bind x (Pi i s k) t ->                  do (av, aty) <- chk u env RType                      convertsC ctxt env aty s                     let apty = simplify initContext env                                         (Bind x (Let aty av) t)-                    return (App fv av, apty)+                    return (App astate fv av, apty)              t -> lift $ tfail $ NonFunctionType fv fty   chk u env ap@(RApp f a)       = do (fv, fty) <- chk u env f@@ -123,7 +129,7 @@                  do convertsC ctxt env aty s                     let apty = simplify initContext env                                         (Bind x (Let aty av) t)-                    return (App fv av, apty)+                    return (App astate fv av, apty)              t -> lift $ tfail $ NonFunctionType fv fty   chk u env RType     | holes = return (TType (UVal 0), TType (UVal 0))@@ -151,10 +157,6 @@           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 TheWorld = Constant WorldType           constType Forgot  = Erased           constType _       = TType (UVal 0)@@ -302,7 +304,7 @@     chkBinders env (P _ n _) = chkName n     -- 'lending' a unique or nulltype variable doesn't count as a use,     -- but we still can't lend something that's already been used.-    chkBinders env (App (App (P _ (NS (UN lend) [owner]) _) t) a)+    chkBinders env (App _ (App _ (P _ (NS (UN lend) [owner]) _) t) a)        | isVar a && owner == txt "Ownership" &&          (lend == txt "lend" || lend == txt "Read")             = do chkBinders env t -- Check the type normally@@ -311,7 +313,7 @@                  put (filter (\(n, (ok, _)) -> ok /= LendOnly) st)                  chkBinders env a                  put st -- Reset the old state after checking the argument-    chkBinders env (App f a) = do chkBinders env f; chkBinders env a+    chkBinders env (App _ f a) = do chkBinders env f; chkBinders env a     chkBinders env (Bind n b t)        = do chkBinderName env n b             st <- get
src/Idris/Core/Unify.hs view
@@ -96,22 +96,22 @@     -- but it scares me. However, matching is never guaranteed to give a unique     -- answer, merely a valid one, so perhaps we're okay.     -- In other words: it may vanish without warning some day :)-    un names x tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a)+    un names x tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a)         | (P (TCon _ _) _ _, _) <- unApply x,           holeIn env f || f `elem` holes            = let n' = uniqueName (sMN 0 "mv") (map fst env) in              checkCycle names (f, Bind n' (Lam t) x)-    un names tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) x+    un names tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a) x         | (P (TCon _ _) _ _, _) <- unApply x,           holeIn env f || f `elem` holes            = let n' = uniqueName fn (map fst env) in                  checkCycle names (f, Bind n' (Lam t) x)-    un names x tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a)+    un names x tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a)         | (P (DCon _ _ _) _ _, _) <- unApply x,           holeIn env f || f `elem` holes            = let n' = uniqueName (sMN 0 "mv") (map fst env) in              checkCycle names (f, Bind n' (Lam t) x)-    un names tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) x+    un names tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a) x         | (P (DCon _ _ _) _ _, _) <- unApply x,           holeIn env f || f `elem` holes            = let n' = uniqueName fn (map fst env) in@@ -135,7 +135,7 @@         = do h1 <- uB bnames bx by              h2 <- un (((x, y), binderTy bx) : bnames) sx sy              combine bnames h1 h2-    un names (App fx ax) (App fy ay)+    un names (App _ fx ax) (App _ fy ay)         = do hf <- un names fx fy              ha <- un names ax ay              combine names hf ha@@ -218,7 +218,7 @@     bind i ns tm       | i < 0 = tm       | otherwise = let ((x,y),ty) = ns!!i in-                        App (Bind y (Lam ty) (bind (i-1) ns tm))+                        App MaybeHoles (Bind y (Lam ty) (bind (i-1) ns tm))                             (P Bound x ty)  renameBinders env (x, t) = (x, renameBindersTm env t)@@ -233,12 +233,12 @@                            (uniqueBinders (n':env) (rename n n' sc))         | otherwise = Bind n (fmap (uniqueBinders (n:env)) b)                              (uniqueBinders (n:env) sc)-    uniqueBinders env (App f a) = App (uniqueBinders env f) (uniqueBinders env a)+    uniqueBinders env (App s f a) = App s (uniqueBinders env f) (uniqueBinders env a)     uniqueBinders env 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' (App s f a) = App s (rename n n' f) (rename n n' a)     rename n n' t = t      explicitHole (Bind n (Hole ty) sc)@@ -280,7 +280,7 @@  hasv :: TT Name -> Bool hasv (V x) = True-hasv (App f a) = hasv f || hasv a+hasv (App _ f a) = hasv f || hasv a hasv (Bind x b sc) = hasv (binderTy b) || hasv sc hasv _ = False @@ -300,11 +300,12 @@         res ->                let topxn = renameBindersTm env (normalise ctxt env topx)                    topyn = renameBindersTm env (normalise ctxt env topy) in---                     trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n" ++ show res ++ "\n\n") $+--                     trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n") $                      case runStateT (un False [] topxn topyn)                                 (UI 0 []) of                        OK (v, UI _ fails) ->                             do v' <- trimSolutions (topx, xfrom) (topy, yfrom) from env v+--                                trace ("OK " ++ show (topxn, topyn, v, holes)) $                                 return (map (renameBinders env) v', reverse fails) --         Error e@(CantUnify False _ _ _ _ _)  -> tfail e                        Error e -> tfail e@@ -315,14 +316,12 @@      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 (App _ f a)        = injective f -- && injective a     injective _                  = False  --     injectiveVar (P _ (MN _ _) _) = True -- TMP HACK     injectiveVar (P _ n _)        = n `elem` inj-    injectiveVar (App f a)        = injectiveVar f -- && injective a+    injectiveVar (App _ f a)      = injectiveVar f -- && injective a     injectiveVar _ = False      injectiveApp x = injective x || injectiveVar x@@ -426,18 +425,18 @@     un' fn names topx@(Bind n (Hole t) sc) y = unifyTmpFail topx y     un' fn names x topy@(Bind n (Hole t) sc) = unifyTmpFail x topy -    un' fn bnames appx@(App _ _) appy@(App _ _)+    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' _)))+    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+    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' 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' 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@@ -447,14 +446,14 @@     -- 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 i t k) y)+    un' fn bnames (App _ f x) (Bind n (Pi i t k) y)       | noOccurrence n y && injectiveApp f         = do ux <- un' False bnames x y              uf <- un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))                                       (Bind n (Pi i t k) (V 1)))              combine bnames ux uf -    un' fn bnames (Bind n (Pi i t k) y) (App f x)+    un' fn bnames (Bind n (Pi i t k) y) (App _ f x)       | noOccurrence n y && injectiveApp f         = do ux <- un' False bnames y x              uf <- un' False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))@@ -481,7 +480,7 @@                            else do put (UI s ((x, y, True, env, err, from, Unify) : f))                                    return [] -- lift $ tfail err -    unApp fn bnames appx@(App fx ax) appy@(App fy ay)+    unApp fn bnames appx@(App _ fx ax) appy@(App _ fy ay)         -- shortcut for the common case where we just want to check the         -- arguments are correct          | (injectiveApp fx && fx == fy)@@ -545,7 +544,7 @@             rigid (P (TCon _ _) _ _) = True             rigid t@(P Ref _ _)      = inenv t || globmetavar t             rigid (Constant _)       = True-            rigid (App f a)          = rigid f && rigid a+            rigid (App _ f a)        = rigid f && rigid a             rigid t                  = not (metavar t) || globmetavar t              globmetavar t = case unApply t  of@@ -636,7 +635,7 @@     bind i ns tm       | i < 0 = tm       | otherwise = let ((x,y),ty) = ns!!i in-                        App (Bind y (Lam ty) (bind (i-1) ns tm))+                        App MaybeHoles (Bind y (Lam ty) (bind (i-1) ns tm))                             (P Bound x ty)      combineArgs bnames args = ca [] args where@@ -658,16 +657,16 @@ 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 (App _ f x) = let fs = boundVs i f+                            xs = boundVs i x in+                            nub (fs ++ xs) boundVs i _ = []  highV :: Int -> Term -> Int highV i (V j) | j > i = j                 | otherwise = i highV i (Bind n b sc) = maximum [i, highV i (binderTy b), (highV i sc - 1)]-highV i (App f x) = max (highV i f) (highV i x)+highV i (App _ f x) = max (highV i f) (highV i x) highV i _ = i  envPos x i [] = 0@@ -683,9 +682,9 @@ -- -- Issue #1722 on the issue tracker https://github.com/idris-lang/Idris-dev/issues/1722 ---recoverable t@(App _ _) _+recoverable t@(App _ _ _) _     | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False-recoverable _ t@(App _ _)+recoverable _ t@(App _ _ _)     | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False recoverable (P (DCon _ _ _) x _) (P (DCon _ _ _) y _) = x == y recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) = x == y@@ -696,20 +695,22 @@ 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 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')     | f == f' = recoverable a a'-recoverable (App f a) (App f' a')+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+    | (Constant _) <- f = False recoverable (Bind _ (Pi _ _ _) sc) f     | (P (DCon _ _ _) _ _, _) <- unApply f = False     | (P (TCon _ _) _ _, _) <- unApply f = False+    | (Constant _) <- f = False recoverable (Bind _ (Lam _) sc) f = recoverable sc f recoverable f (Bind _ (Lam _) sc) = recoverable f sc recoverable x y = True
src/Idris/Coverage.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-}-+{-| The coverage and totality checkers for Idris are in this module.+-} module Idris.Coverage where  import Idris.Core.TT@@ -120,6 +121,52 @@                                 as' <- mkArg as                                 return (a':as') +-- | Does this error result rule out a case as valid when coverage checking?+validCoverageCase :: Context -> Err -> Bool+validCoverageCase ctxt (CantUnify _ (topx, _) (topy, _) e _ _)+    = let topx' = normalise ctxt [] topx+          topy' = normalise ctxt [] topy in+          not (sameFam topx' topy' || not (validCoverageCase ctxt e))+  where sameFam topx topy+            = case (unApply topx, unApply topy) of+                   ((P _ x _, _), (P _ y _, _)) -> x == y+                   _ -> False+validCoverageCase ctxt (CantConvert _ _ _) = False+validCoverageCase ctxt (At _ e) = validCoverageCase ctxt e+validCoverageCase ctxt (Elaborating _ _ e) = validCoverageCase ctxt e+validCoverageCase ctxt (ElaboratingArg _ _ _ e) = validCoverageCase ctxt e+validCoverageCase ctxt _ = True++-- | Check whether an error is recoverable in the sense needed for+-- coverage checking.+recoverableCoverage :: Context -> Err -> Bool+recoverableCoverage ctxt (CantUnify r (topx, _) (topy, _) e _ _)+    = let topx' = normalise ctxt [] topx+          topy' = normalise ctxt [] topy in+          r || checkRec topx' topy'+  where -- different notion of recoverable than in unification, since we+        -- have no metavars -- just looking to see if a constructor is failing+        -- to unify with a function that may be reduced later+        checkRec (App _ f a) p@(P _ _ _) = checkRec f p+        checkRec p@(P _ _ _) (App _ f a) = checkRec p f+        checkRec fa@(App _ _ _) fa'@(App _ _ _)+            | (f, as) <- unApply fa,+              (f', as') <- unApply fa'+                 = if (length as /= length as')+                      then checkRec f f'+                      else checkRec f f' && and (zipWith checkRec as as')+        checkRec (P xt x _) (P yt y _) = x == y || ntRec xt yt+        checkRec _ _ = False++        ntRec x y | Ref <- x = True+                  | Ref <- y = True+                  | (Bound, Bound) <- (x, y) = True+                  | otherwise = False -- name is different, unrecoverable+recoverableCoverage ctxt (At _ e) = recoverableCoverage ctxt e+recoverableCoverage ctxt (Elaborating _ _ e) = recoverableCoverage ctxt e+recoverableCoverage ctxt (ElaboratingArg _ _ _ e) = recoverableCoverage ctxt e+recoverableCoverage _ _ = False+ -- FIXME: Just look for which one is the deepest, then generate all -- possibilities up to that depth. -- This and below issues for this function are tracked as Issue #1741 on the issue tracker.@@ -132,8 +179,8 @@   where     -- if they're constants, invent a new one to make sure that     -- constants which are not explicitly handled are covered-    inventConsts cs@(PConstant c : _) = map PConstant (ic' (mapMaybe getConst cs))-      where getConst (PConstant c) = Just c+    inventConsts cs@(PConstant fc c : _) = map (PConstant NoFC) (ic' (mapMaybe getConst cs))+      where getConst (PConstant _ c) = Just c             getConst _ = Nothing     inventConsts xs = xs @@ -179,7 +226,7 @@                 ([pimp (sUN "a") Placeholder True,                   pimp (sUN "P") Placeholder True] ++                  [pexp t,pexp v]) o-    otherPats o@(PConstant c) = inventConsts [o] -- return o+    otherPats o@(PConstant _ c) = inventConsts [o] -- return o     otherPats arg = return Placeholder      ops fc n xs o@@ -231,7 +278,7 @@      -- quick check for constructor equality     quickEq :: PTerm -> PTerm -> Bool-    quickEq (PConstant n) (PConstant n') = n == n'+    quickEq (PConstant _ n) (PConstant _ n') = n == n'     quickEq (PRef _ n) (PRef _ n') = n == n'     quickEq (PApp _ t as) (PApp _ t' as')         | length as == length as'@@ -317,7 +364,7 @@      prodRec n done (_, _, tm) = prod n done False (delazy' True tm)       prod :: Name -> [Name] -> Bool -> Term -> Idris Bool-     prod n done ok ap@(App _ _)+     prod n done ok ap@(App _ _ _)         | (P nt f _, args) <- unApply ap             = do recOK <- checkProdRec (n:done) f                  let ctxt = tt_ctxt i@@ -329,8 +376,8 @@                                  return (and (ok : argsprod) )                          else do argsprod <- mapM (prod n done co) args                                  return (and argsprod)-     prod n done ok (App f a) = liftM2 (&&) (prod n done False f)-                                            (prod n done False a)+     prod n done ok (App _ f a) = liftM2 (&&) (prod n done False f)+                                              (prod n done False a)      prod n done ok (Bind _ (Let t v) sc)          = liftM2 (&&) (prod n done False v) (prod n done False v)      prod n done ok (Bind _ b sc) = prod n done ok sc@@ -350,10 +397,9 @@                    _ -> False      cotype nt n ty = False --- Calculate the totality of a function from its patterns.+-- | Calculate the totality of a function from its patterns. -- Either follow the size change graph (if inductive) or check for -- productivity (if coinductive)- calcTotality :: FC -> Name -> [([Name], Term, Term)] -> Idris Totality calcTotality fc n pats     = do i <- getIState@@ -368,7 +414,7 @@         = case lookupTotal fn (tt_ctxt i) of                [Partial _] -> return (Partial (Other [fn]))                _ -> Nothing-    checkLHS i (App f a) = mplus (checkLHS i f) (checkLHS i a)+    checkLHS i (App _ f a) = mplus (checkLHS i f) (checkLHS i a)     checkLHS _ _ = Nothing  checkTotality :: [Name] -> FC -> Name -> Idris Totality@@ -450,17 +496,16 @@          return t  --- Calculate the size change graph for this definition-+-- | Calculate the size change graph for this definition+-- -- SCG for a function f consists of a list of: --    (g, [(a1, sizechange1), (a2, sizechange2), ..., (an, sizechangen)])-+-- -- where g is a function called -- a1 ... an are the arguments of f in positions 1..n of g -- sizechange1 ... sizechange2 is how their size has changed wrt the input -- to f --    Nothing, if the argument is unrelated to the input- buildSCG :: (FC, Name) -> Idris () buildSCG (_, n) = do    ist <- getIState@@ -477,14 +522,14 @@        x -> error $ "buildSCG: " ++ show (n, x)  delazy = delazy' False -- not lazy codata-delazy' all t@(App f a)+delazy' all t@(App _ f a)      | (P _ (UN l) _, [_, _, arg]) <- unApply t,        l == txt "Force" = delazy' all arg      | (P _ (UN l) _, [P _ (UN lty) _, _, arg]) <- unApply t,        l == txt "Delay" && (all || lty == txt "LazyEval") = delazy arg      | (P _ (UN l) _, [P _ (UN lty) _, arg]) <- unApply t,        l == txt "Lazy'" && (all || lty == txt "LazyEval") = delazy' all arg-delazy' all (App f a) = App (delazy' all f) (delazy' all a)+delazy' all (App s f a) = App s (delazy' all f) (delazy' all a) delazy' all (Bind n b sc) = Bind n (fmap (delazy' all) b) (delazy' all sc) delazy' all t = t @@ -498,7 +543,7 @@                           (f, pargs) = unApply (dePat lhs') in                             findCalls Toplevel (dePat rhs') (patvars lhs') pargs -  findCalls guarded ap@(App f a) pvs pargs+  findCalls guarded ap@(App _ f a) pvs pargs      -- under a call to "assert_total", don't do any checking, just believe      -- that it is total.      | (P _ (UN at) _, [_, _]) <- unApply ap,@@ -519,7 +564,7 @@                                       else Unguarded in               mkChange n args pargs ++                  concatMap (\x -> findCalls nguarded x pvs pargs) args-  findCalls guarded (App f a) pvs pargs+  findCalls guarded (App _ f a) pvs pargs         = findCalls Unguarded f pvs pargs ++ findCalls Unguarded a pvs pargs   findCalls guarded (Bind n (Let t v) e) pvs pargs         = findCalls Unguarded t pvs pargs ++@@ -561,13 +606,13 @@       smaller (Just tyn) a (t, Just tyt)          | a == t = isInductive (fst (unApply (getRetTy tyn)))                                 (fst (unApply (getRetTy tyt)))-      smaller ty a (ap@(App f s), _)+      smaller ty a (ap@(App _ f s), _)           | (P (DCon _ _ _) n _, args) <- unApply ap                = let tyn = getType n in                      any (smaller (ty `mplus` Just tyn) a)                          (zip args (map toJust (getArgTys tyn)))       -- check higher order recursive arguments-      smaller ty (App f s) a = smaller ty f a+      smaller ty (App _ f s) a = smaller ty f a       smaller _ _ _ = False        toJust (n, t) = Just t@@ -660,7 +705,7 @@             = case lookupTotal f (tt_ctxt ist) of                    [Total _] -> Unchecked -- okay so far                    [Partial _] -> Partial (Other [f])-                   x -> error $ "CAN'T HAPPEN: " ++ (show x)+                   x -> error $ "CAN'T HAPPEN: " ++ show x ++ " for " ++ show f         | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)             = Total []     tryPath desc path (e@(f, args) : es) arg
src/Idris/DSL.hs view
@@ -24,7 +24,7 @@     dslifyApp t = t  desugar :: SyntaxInfo -> IState -> PTerm -> PTerm-desugar syn i t = let t' = expandDo (dsl_info syn) t+desugar syn i t = let t' = expandSugar (dsl_info syn) t                   in dslify syn i t'  mkTTName :: FC -> Name -> PTerm@@ -33,8 +33,8 @@         mkList fc (x:xs) = PApp fc (PRef fc (sNS (sUN "::") ["List", "Prelude"]))                                    [ pexp (stringC x)                                    , pexp (mkList fc xs)]-        stringC = PConstant . Str . str-        intC = PConstant . I+        stringC = PConstant fc . Str . str+        intC = PConstant fc . I         reflm n = sNS (sUN n) ["Reflection", "Language"]     in case n of          UN nm     -> PApp fc (PRef fc (reflm "UN")) [ pexp (stringC nm)]@@ -44,72 +44,76 @@                                                      , pexp (stringC nm)]          otherwise -> PRef fc $ reflm "NErased" -expandDo :: DSL -> PTerm -> PTerm-expandDo dsl (PLam fc n ty tm)+expandSugar :: DSL -> PTerm -> PTerm+expandSugar dsl (PLam fc n nfc ty tm)     | Just lam <- dsl_lambda dsl         = let sc = PApp fc lam [ pexp (mkTTName fc n)                                , pexp (var dsl n tm 0)]-          in expandDo dsl sc-expandDo dsl (PLam fc n ty tm) = PLam fc n (expandDo dsl ty) (expandDo dsl tm)-expandDo dsl (PLet fc n ty v tm)+          in expandSugar dsl sc+expandSugar dsl (PLam fc n nfc ty tm) = PLam fc n nfc (expandSugar dsl ty) (expandSugar dsl tm)+expandSugar dsl (PLet fc n nfc ty v tm)     | Just letb <- dsl_let dsl         = let sc = PApp (fileFC "(dsl)") letb [ pexp (mkTTName fc n)                                               , pexp v                                               , pexp (var dsl n tm 0)]-          in expandDo dsl sc-expandDo dsl (PLet fc n ty v tm) = PLet fc n (expandDo dsl ty) (expandDo dsl v) (expandDo dsl tm)-expandDo dsl (PPi p n ty tm)+          in expandSugar dsl sc+expandSugar dsl (PLet fc n nfc ty v tm) = PLet fc n nfc (expandSugar dsl ty) (expandSugar dsl v) (expandSugar dsl tm)+expandSugar dsl (PPi p n fc ty tm)     | Just pi <- dsl_pi dsl         = let sc = PApp (fileFC "(dsl)") pi [ pexp (mkTTName (fileFC "(dsl)") n)                                             , pexp ty                                             , pexp (var dsl n tm 0)]-          in expandDo dsl sc-expandDo dsl (PPi p n ty tm) = PPi p n (expandDo dsl ty) (expandDo dsl tm)-expandDo dsl (PApp fc t args) = PApp fc (expandDo dsl t)-                                        (map (fmap (expandDo dsl)) args)-expandDo dsl (PAppBind fc t args) = PAppBind fc (expandDo dsl t)-                                                (map (fmap (expandDo dsl)) args)-expandDo dsl (PCase fc s opts) = PCase fc (expandDo dsl s)-                                        (map (pmap (expandDo dsl)) opts)-expandDo dsl (PEq fc lt rt l r) = PEq fc (expandDo dsl lt) (expandDo dsl rt)-                                         (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 p l t r) = PDPair fc p (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-expandDo dsl (PGoal fc r n sc)-    = PGoal fc (expandDo dsl r) n (expandDo dsl sc)-expandDo dsl (PDoBlock ds)-    = expandDo dsl $ debind (dsl_bind dsl) (block (dsl_bind dsl) ds)+          in expandSugar dsl sc+expandSugar dsl (PPi p n fc ty tm) = PPi p n fc (expandSugar dsl ty) (expandSugar dsl tm)+expandSugar dsl (PApp fc t args) = PApp fc (expandSugar dsl t)+                                        (map (fmap (expandSugar dsl)) args)+expandSugar dsl (PAppBind fc t args) = PAppBind fc (expandSugar dsl t)+                                                (map (fmap (expandSugar dsl)) args)+expandSugar dsl (PCase fc s opts) = PCase fc (expandSugar dsl s)+                                        (map (pmap (expandSugar dsl)) opts)+expandSugar dsl (PIfThenElse fc c t f) =+  PApp fc (PRef NoFC (sUN "ifThenElse"))+       [ PExp 0 [] (sMN 0 "condition") $ expandSugar dsl c+       , PExp 0 [] (sMN 0 "whenTrue") $ expandSugar dsl t+       , PExp 0 [] (sMN 0 "whenFalse") $ expandSugar dsl f+       ]+expandSugar dsl (PPair fc p l r) = PPair fc p (expandSugar dsl l) (expandSugar dsl r)+expandSugar dsl (PDPair fc p l t r) = PDPair fc p (expandSugar dsl l) (expandSugar dsl t)+                                               (expandSugar dsl r)+expandSugar dsl (PAlternative a as) = PAlternative a (map (expandSugar dsl) as)+expandSugar dsl (PHidden t) = PHidden (expandSugar dsl t)+expandSugar dsl (PNoImplicits t) = PNoImplicits (expandSugar dsl t)+expandSugar dsl (PUnifyLog t) = PUnifyLog (expandSugar dsl t)+expandSugar dsl (PDisamb ns t) = PDisamb ns (expandSugar dsl t)+expandSugar dsl (PReturn fc) = dsl_return dsl+expandSugar dsl (PRewrite fc r t ty)+    = PRewrite fc r (expandSugar dsl t) ty+expandSugar dsl (PGoal fc r n sc)+    = PGoal fc (expandSugar dsl r) n (expandSugar dsl sc)+expandSugar dsl (PDoBlock ds)+    = expandSugar dsl $ debind (dsl_bind dsl) (block (dsl_bind dsl) ds)   where     block b [DoExp fc tm] = tm     block b [a] = PElabError (Msg "Last statement in do block must be an expression")-    block b (DoBind fc n tm : rest)-        = PApp fc b [pexp tm, pexp (PLam fc n Placeholder (block b rest))]+    block b (DoBind fc n nfc tm : rest)+        = PApp fc b [pexp tm, pexp (PLam fc n nfc Placeholder (block b rest))]     block b (DoBindP fc p tm alts : rest)-        = PApp fc b [pexp tm, pexp (PLam fc (sMN 0 "bpat") Placeholder+        = PApp fc b [pexp tm, pexp (PLam fc (sMN 0 "bpat") NoFC Placeholder                                    (PCase fc (PRef fc (sMN 0 "bpat"))                                              ((p, block b rest) : alts)))]-    block b (DoLet fc n ty tm : rest)-        = PLet fc n ty tm (block b rest)+    block b (DoLet fc n nfc ty tm : rest)+        = PLet fc n nfc ty tm (block b rest)     block b (DoLetP fc p tm : rest)         = PCase fc tm [(p, block b rest)]     block b (DoExp fc tm : rest)         = PApp fc b             [pexp tm,-             pexp (PLam fc (sMN 0 "bindx") Placeholder (block b rest))]+             pexp (PLam fc (sMN 0 "bindx") NoFC 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-expandDo dsl (PRunTactics fc tm) = PRunTactics fc $ expandDo dsl tm-expandDo dsl t = t+expandSugar dsl (PIdiom fc e) = expandSugar dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e+expandSugar dsl (PRunElab fc tm) = PRunElab fc $ expandSugar dsl tm+expandSugar dsl t = t  -- | Replace DSL-bound variable in a term var :: DSL -> Name -> PTerm -> Int -> PTerm@@ -118,22 +122,21 @@         case dsl_var dsl of             Nothing -> PElabError (Msg "No 'variable' defined in dsl")             Just v -> PApp fc v [pexp (mkVar fc i)]-    v' i (PLam fc n ty sc)+    v' i (PLam fc n nfc ty sc)         | Nothing <- dsl_lambda dsl-            = PLam fc n ty (v' i sc)-        | otherwise = PLam fc n (v' i ty) (v' (i + 1) sc)-    v' i (PLet fc n ty val sc)+            = PLam fc n nfc ty (v' i sc)+        | otherwise = PLam fc n nfc (v' i ty) (v' (i + 1) sc)+    v' i (PLet fc n nfc ty val sc)         | Nothing <- dsl_let dsl-            = PLet fc n (v' i ty) (v' i val) (v' i sc)-        | otherwise = PLet fc n (v' i ty) (v' i val) (v' (i + 1) sc)-    v' i (PPi p n ty sc)+            = PLet fc n nfc (v' i ty) (v' i val) (v' i sc)+        | otherwise = PLet fc n nfc (v' i ty) (v' i val) (v' (i + 1) sc)+    v' i (PPi p n fc ty sc)         | Nothing <- dsl_pi dsl-            = PPi p n (v' i ty) (v' i sc)-        | otherwise = PPi p n (v' i ty) (v' (i+1) sc)+            = PPi p n fc (v' i ty) (v' i sc)+        | otherwise = PPi p n fc (v' i ty) (v' (i+1) sc)     v' i (PTyped l r)    = PTyped (v' i l) (v' i r)     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 lt rt l r) = PEq f (v' i lt) (v' i rt) (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 p l t r) = PDPair f p (v' i l) (v' i t) (v' i r)     v' i (PAlternative a as) = PAlternative a $ map (v' i) as@@ -184,9 +187,9 @@          = do t' <- db' t               args' <- mapM dbArg args               return (PApp fc t' args')-    db' (PLam fc n ty sc) = return (PLam fc n ty (debind b sc))-    db' (PLet fc n ty v sc) = do v' <- db' v-                                 return (PLet fc n ty v' (debind b sc))+    db' (PLam fc n nfc ty sc) = return (PLam fc n nfc ty (debind b sc))+    db' (PLet fc n nfc ty v sc) = do v' <- db' v+                                     return (PLet fc n nfc 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 p l r) = do l' <- db' l@@ -195,7 +198,7 @@     db' (PDPair fc p l t r) = do l' <- db' l                                  r' <- db' r                                  return (PDPair fc p l' t r')-    db' (PRunTactics fc t) = fmap (PRunTactics fc) (db' t)+    db' (PRunElab fc t) = fmap (PRunElab fc) (db' t)     db' t = return t      dbArg a = do t' <- db' (getTm a)@@ -209,6 +212,6 @@      bindAll [] tm = tm     bindAll ((n, fc, t) : bs) tm-       = PApp fc b [pexp t, pexp (PLam fc n Placeholder (bindAll bs tm))]+       = PApp fc b [pexp t, pexp (PLam fc n NoFC Placeholder (bindAll bs tm))]
src/Idris/DataOpts.hs view
@@ -63,21 +63,27 @@     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)+    applyOpts (P _ (NS (UN fn) mod) _)+       | fn == txt "divNat" && mod == prel+        = return (P Ref (sUN "prim__sdivBigInt") Erased)+    applyOpts (P _ (NS (UN fn) mod) _)+       | fn == txt "modNat" && mod == prel+        = return (P Ref (sUN "prim__sremBigInt") Erased)+    applyOpts (App _ (P _ (NS (UN fn) mod) _) x)        | fn == txt "fromIntegerNat" && mod == prel         = applyOpts x     applyOpts (P _ (NS (UN fn) mod) _)        | fn == txt "fromIntegerNat" && mod == prel-        = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)+        = return (App Complete (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)+         = return (App Complete (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)     applyOpts c@(P (DCon t arity uniq) n _)         = return $ applyDataOptRT n t arity uniq []-    applyOpts t@(App f a)+    applyOpts t@(App s f a)         | (c@(P (DCon t arity uniq) n _), args) <- unApply t             = applyDataOptRT n t arity uniq <$> mapM applyOpts args-        | otherwise = App <$> applyOpts f <*> applyOpts a+        | otherwise = App s <$> applyOpts f <*> applyOpts a     applyOpts (Bind n b t) = Bind n <$> applyOpts b <*> applyOpts t     applyOpts (Proj t i) = Proj <$> applyOpts t <*> pure i     applyOpts t = return t@@ -103,6 +109,6 @@           = 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))+          = App Complete (App Complete (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))      doOpts n args = mkApp (P (DCon tag arity uniq) n Erased) args
src/Idris/DeepSeq.hs view
@@ -119,6 +119,7 @@         rnf Reflection = ()         rnf (Specialise x1) = rnf x1 `seq` ()         rnf Constructor = ()+        rnf AutoHint = ()  instance NFData DataOpt where         rnf Codata = ()@@ -128,13 +129,15 @@  instance (NFData t) => NFData (PDecl' t) where         rnf (PFix x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()-        rnf (PTy x1 x2 x3 x4 x5 x6 x7)+        rnf (PTy x1 x2 x3 x4 x5 x6 x7 x8)           = rnf x1 `seq`               rnf x2 `seq`-                rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()-        rnf (PPostulate x1 x2 x3 x4 x5 x6)+                rnf x3 `seq`+                  rnf x4 `seq`+                    rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` ()+        rnf (PPostulate x1 x2 x3 x4 x5 x6 x7)           = rnf x1 `seq`-              rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()+              rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()         rnf (PClauses x1 x2 x3 x4)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()         rnf (PCAF x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()@@ -143,24 +146,40 @@               rnf x2 `seq`                 rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()         rnf (PParams x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()-        rnf (PNamespace x1 x2) = rnf x1 `seq` rnf x2 `seq` ()-        rnf (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9)+        rnf (PNamespace x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)           = rnf x1 `seq`               rnf x2 `seq`                 rnf x3 `seq`-                  rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` ()-        rnf (PClass x1 x2 x3 x4 x5 x6 x8 x7 x9)+                  rnf x4 `seq`+                    rnf x5 `seq`+                      rnf x6 `seq`+                        rnf x7 `seq`+                          rnf x8 `seq`+                            rnf x9 `seq`+                              rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` ()+        rnf (PClass x1 x2 x3 x4 x5 x6 x8 x7 x9 x10 x11 x12)           = rnf x1 `seq`               rnf x2 `seq`-                rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` ()-        rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)+                rnf x3 `seq`+                  rnf x4 `seq`+                    rnf x5 `seq`+                      rnf x6 `seq`+                        rnf x7 `seq`+                          rnf x8 `seq`+                            rnf x9 `seq`+                              rnf x10 `seq`+                                rnf x11 `seq` rnf x12 `seq` ()+        rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)           = rnf x1 `seq`               rnf x2 `seq`                 rnf x3 `seq`                   rnf x4 `seq`                     rnf x5 `seq`                       rnf x6 `seq`-                        rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` ()+                        rnf x7 `seq`+                          rnf x8 `seq`+                            rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` ()         rnf (PDSL x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()@@ -190,30 +209,29 @@           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()  instance (NFData t) => NFData (PData' t) where-        rnf (PDatadecl x1 x2 x3)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()-        rnf (PLaterdecl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+        rnf (PDatadecl x1 x2 x3 x4)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+        rnf (PLaterdecl x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()  instance NFData PTerm where         rnf (PQuote x1) = rnf x1 `seq` ()         rnf (PRef x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PInferRef x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PPatvar x1 x2) = rnf x1 `seq` rnf x2 `seq` ()-        rnf (PLam _ x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()-        rnf (PPi x1 x2 x3 x4)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()-        rnf (PLet _ x1 x2 x3 x4)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+        rnf (PLam _ x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+        rnf (PPi x1 x2 x3 x4 x5)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()+        rnf (PLet _ x1 x2 x3 x4 x5)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()         rnf (PTyped x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PAppImpl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PApp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()         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 (PIfThenElse x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()         rnf (PTrue x1 x2) = rnf x1 `seq` rnf x2 `seq` ()-        rnf (PRefl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PResolveTC x1) = rnf x1 `seq` ()-        rnf (PEq x1 x2 x3 x4 x5) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()         rnf (PRewrite x1 x2 x3 x4)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()         rnf (PPair x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()@@ -222,16 +240,16 @@         rnf (PAs x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()         rnf (PAlternative x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PHidden x1) = rnf x1 `seq` ()-        rnf PType = ()+        rnf (PType fc) = rnf fc `seq` ()         rnf (PUniverse _) = ()         rnf (PGoal x1 x2 x3 x4)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()-        rnf (PConstant x1) = x1 `seq` ()+        rnf (PConstant x1 x2) = x1 `seq` x2 `seq` ()         rnf Placeholder = ()         rnf (PDoBlock x1) = rnf x1 `seq` ()         rnf (PIdiom x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PReturn x1) = rnf x1 `seq` ()-        rnf (PMetavar x1) = rnf x1 `seq` ()+        rnf (PMetavar x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PProof x1) = rnf x1 `seq` ()         rnf (PTactics x1) = rnf x1 `seq` ()         rnf (PElabError x1) = rnf x1 `seq` ()@@ -242,8 +260,13 @@         rnf (PNoImplicits x1) = rnf x1 `seq` ()         rnf (PQuasiquote x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PUnquote x1) = rnf x1 `seq` ()-        rnf (PRunTactics x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+        rnf (PQuoteName x1) = rnf x1 `seq` ()+        rnf (PRunElab x1 x2) = rnf x1 `seq` rnf x2 `seq` () +instance NFData PAltType where+        rnf (ExactlyOne x1) = rnf x1 `seq` ()+        rnf FirstSuccess = ()+ instance (NFData t) => NFData (PTactic' t) where         rnf (Intro x1) = rnf x1 `seq` ()         rnf Intros = ()@@ -295,10 +318,10 @@  instance (NFData t) => NFData (PDo' t) where         rnf (DoExp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()-        rnf (DoBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (DoBind x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()         rnf (DoBindP x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()-        rnf (DoLet x1 x2 x3 x4)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+        rnf (DoLet x1 x2 x3 x4 x5)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()         rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()  instance (NFData t) => NFData (PArg' t) where
src/Idris/Delaborate.hs view
@@ -13,6 +13,9 @@ import Idris.Docstrings (overview, renderDocstring, renderDocTerm) import Idris.ErrReverse +import Prelude hiding ((<$>))++import Data.Maybe (mapMaybe) import Data.List (intersperse, nub) import qualified Data.Text as T import Control.Monad.State@@ -47,7 +50,7 @@   where     un = fileFC "(val)" -    de env _ (App f a) = deFn env f [a]+    de env _ (App _ f a) = resugarApp env $ deFn env f [a]     de env _ (V i)     | i < length env = PRef un (snd (env!!i))                        | otherwise = PRef un (sUN ("v" ++ show i ++ ""))     de env _ (P _ n _) | n == unitTy = PTrue un IsType@@ -58,40 +61,40 @@                                   Just (Just _, mi, _) -> mkMVApp n []                                   _ -> PRef un n     de env _ (Bind n (Lam ty) sc)-          = PLam un n (de env [] ty) (de ((n,n):env) [] sc)+          = PLam un n NoFC (de env [] ty) (de ((n,n):env) [] sc)     de env is (Bind n (Pi (Just impl) ty _) sc)        | tcinstance impl-          = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)+          = PPi constraint n NoFC (de env [] ty) (de ((n,n):env) is sc)        | otherwise-          = PPi (Imp [] Dynamic False (Just impl)) n (de env [] ty) (de ((n,n):env) is sc)+          = PPi (Imp [] Dynamic False (Just impl)) n NoFC (de env [] ty) (de ((n,n):env) is sc)     de env ((PImp { argopts = opts }):is) (Bind n (Pi _ ty _) sc)-          = PPi (Imp opts Dynamic False Nothing) n (de env [] ty) (de ((n,n):env) is sc)+          = PPi (Imp opts Dynamic False Nothing) n NoFC (de env [] ty) (de ((n,n):env) is sc)     de env (PConstraint _ _ _ _:is) (Bind n (Pi _ ty _) sc)-          = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)+          = PPi constraint n NoFC (de env [] ty) (de ((n,n):env) is sc)     de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi _ ty _) sc)-          = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)+          = PPi (tacimpl tac) n NoFC (de env [] ty) (de ((n,n):env) is sc)     de env (plic:is) (Bind n (Pi _ ty _) sc)           = PPi (Exp (argopts plic) Dynamic False)-                n+                n NoFC                 (de env [] ty)                 (de ((n,n):env) is sc)     de env [] (Bind n (Pi _ ty _) sc)-          = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)+          = PPi expl n NoFC (de env [] ty) (de ((n,n):env) [] sc)      de env imps (Bind n (Let ty val) sc)           | isCaseApp sc           , (P _ cOp _, args) <- unApply sc           , Just caseblock    <- delabCase env imps n val cOp args = caseblock           | otherwise    =-              PLet un n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)+              PLet un n NoFC (de env [] ty) (de env [] val) (de ((n,n):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 plic (Bind n bb sc) = de ((n,n):env) [] sc-    de env _ (Constant i) = PConstant i+    de env _ (Constant i) = PConstant NoFC i     de env _ (Proj _ _) = error "Delaboration got run-time-only Proj!"     de env _ Erased = Placeholder     de env _ Impossible = Placeholder-    de env _ (TType i) = PType+    de env _ (TType i) = PType un     de env _ (UType u) = PUniverse u      dens x | fullname = x@@ -101,21 +104,18 @@                               _ -> ns     dens n = n -    deFn env (App f a) args = deFn env f (a:args)+    deFn env (App _ f a) args = deFn env f (a:args)     deFn env (P _ n _) [l,r]          | n == pairTy    = PPair un IsType (de env [] l) (de env [] r)-         | n == eqCon     = PRefl un (de env [] r)-         | n == sUN "lazy" = de env [] r+         | n == sUN "lazy" = de env [] r -- TODO: Fix string based matching     deFn env (P _ n _) [ty, Bind x (Lam _) r]-         | n == sUN "Sigma"+         | n == sigmaTy                = PDPair un IsType (PRef un x) (de env [] ty)                            (de ((x,x):env) [] (instantiate (P Bound x ty) r))     deFn env (P _ n _) [lt,rt,l,r]          | n == pairCon = PPair un IsTerm (de env [] l) (de env [] r)-         | n == eqTy    = PEq un (de env [] lt) (de env [] rt)-                                 (de env [] l) (de env [] r)-         | n == sUN "Sg_intro" = PDPair un IsTerm (de env [] l) Placeholder-                                           (de env [] r)+         | n == sigmaCon = PDPair un IsTerm (de env [] l) Placeholder+                                             (de env [] r)     deFn env f@(P _ n _) args          | n `elem` map snd env               = PApp un (de env [] f) (map pexp (map (de env []) args))@@ -128,9 +128,9 @@     deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args))      mkMVApp n []-            = PMetavar n+            = PMetavar NoFC n     mkMVApp n args-            = PApp un (PMetavar n) (map pexp args)+            = PApp un (PMetavar NoFC n) (map pexp args)     mkPApp n args         | Just imps <- lookupCtxtExact n (idris_implicits ist)             = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args)@@ -147,6 +147,17 @@             isCN (SN (CaseN _)) = True             isCN _ = False +    resugarApp env (PApp _ (PRef _ n) args)+                 | [c, t, f] <- mapMaybe explicitTerm args+                 , basename n == sUN "ifThenElse"+                 = PIfThenElse un c (dedelay t) (dedelay f)+      where dedelay (PApp _ (PRef _ delay) [_, _, obj])+              | delay == sUN "Delay" = getTm obj+            dedelay x = x+            explicitTerm (PExp {getTm = tm}) = Just tm+            explicitTerm _ = Nothing+    resugarApp env tm = tm+     delabCase :: [(Name, Name)] -> [PArg] -> Name -> Term -> Name -> [Term] -> Maybe PTerm     delabCase env imps scvar scrutinee caseName caseArgs =       do cases <- case lookupCtxt caseName (idris_patdefs ist) of@@ -161,7 +172,7 @@                         | otherwise = tm             nonVar [] = error "Tried to delaborate empty case list"             nonVar [x] = x-            nonVar (x@(App _ _) : _) = x+            nonVar (x@(App _ _ _) : _) = x             nonVar (x@(P (DCon _ _ _) _ _) : _) = x             nonVar (x:xs) = nonVar xs -- | How far to indent sub-errors@@ -254,9 +265,9 @@                y)) <>   if (opt_errContext (idris_options i)) then line <> showSc i env else empty     where flagUnique (Bind n (Pi i t k@(UType u)) sc)-              = App (P Ref (sUN (show u)) Erased)+              = App Complete (P Ref (sUN (show u)) Erased)                     (Bind n (Pi i (flagUnique t) k) (flagUnique sc))-          flagUnique (App f a) = App (flagUnique f) (flagUnique a)+          flagUnique (App s f a) = App s (flagUnique f) (flagUnique a)           flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc)           flagUnique t = t pprintErr' i (CantSolveGoal x env) =@@ -295,7 +306,7 @@         <> annName n <$>         text "(Type class arguments must be injective)" pprintErr' i (CantResolveAlts as) = text "Can't disambiguate name:" <+>-                                    align (cat (punctuate (comma <> space) (map (fmap (fancifyAnnots i) . annName) as)))+                                    align (cat (punctuate (comma <> space) (map (fmap (fancifyAnnots i True) . annName) as))) pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n pprintErr' i (WithFnType ty) =@@ -309,7 +320,14 @@     text "Please note that 'induction' is experimental." <$>     text "Only types declared with '%elim' can be used." <$>     text "Consider writing a pattern matching definition instead."-pprintErr' i UniverseError = text "Universe inconsistency"+pprintErr' i (UniverseError fc uexp old new suspects) =+  text "Universe inconsistency." <>+  (indented . vsep) [ text "Working on:" <+> text (show uexp)+                    , text "Old domain:" <+> text (show old)+                    , text "New domain:" <+> text (show new)+                    , text "Involved constraints:" <+>+                      (indented . vsep) (map (text . show) suspects)+                    ] pprintErr' i (UniqueError NullType n)            = text "Borrowed name" <+> annName' n (showbasic n)                   <+> text "must not be used on RHS"@@ -371,12 +389,13 @@   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)-pprintErr' i (ElabDebug msg tm holes) =+pprintErr' i (ElabScriptDebug msg tm holes) =   text "Elaboration halted." <>-  maybe empty (indented . text) msg <> line <>-  text "Term: " <> indented (pprintTT [] tm) <> line <>+  maybe empty (indented . text) msg <>+  line <> line <>   text "Holes:" <>-  indented (vsep (map ppHole holes))+  indented (vsep (map ppHole holes)) <> line <> line <>+  text "Term: " <> indented (pprintTT [] tm)    where ppHole :: (Name, Type, Env) -> Doc OutputAnnotation         ppHole (hn, goal, env) =@@ -392,6 +411,9 @@           pprintTT ns (binderTy b) <>           line <>           ppAssumptions (n:ns) rest+pprintErr' i (ElabScriptStuck tm) =+  text "Can't run" <+> pprintTT [] tm <+> text "as an elaborator script." <$>+  text "Is it a stuck term?"  -- | Make sure the machine invented names are shown helpfully to the user, so -- that any names which differ internally also differ visibly@@ -421,7 +443,7 @@      rename :: [(Name, Name)] -> Term -> Term     rename ns (P nt x t) | Just x' <- lookup x ns = P nt x' t-    rename ns (App f a) = App (rename ns f) (rename ns a)+    rename ns (App s f a) = App s (rename ns f) (rename ns a)     rename ns (Bind x b sc)            = let b' = fmap (rename ns) b                  sc' = rename ns sc in@@ -452,41 +474,14 @@                          else (a { getTm = a' } : as',                                b { getTm = b' } : bs')              addShows xs ys = (xs, ys)-    addI (PLam fc n a b) (PLam fc' n' c d)-         = let (a', c') = addI a c-               (b', d') = addI b d in-               (PLam fc n a' b', PLam fc' n' c' d')-    addI (PPi p n a b) (PPi p' n' c d)+    addI (PLam fc n nfc a b) (PLam fc' n' nfc' c d)          = let (a', c') = addI a c                (b', d') = addI b d in-               (PPi p n a' b', PPi p' n' c' d')-    addI (PRefl fc a) (PRefl fc' b)-         = let (a', b') = addI a b in-               (PRefl fc a', PRefl fc' b')-    addI (PEq fc at bt a b) (PEq fc' ct dt c d)-         | trace (show (at,bt)) False = undefined-         | at `expLike` ct && bt `expLike` dt+               (PLam fc n nfc a' b', PLam fc' n' nfc' c' d')+    addI (PPi p n fc a b) (PPi p' n' fc' c d)          = let (a', c') = addI a c                (b', d') = addI b d in-               (PEq fc at bt a' b', PEq fc' ct dt c' d')-         | otherwise-         = let (at', ct') = addI at ct-               (bt', dt') = addI bt dt-               (a', c') = addI a c-               (b', d') = addI b d-               showa = if at `expLike` ct then [] else [AlwaysShow]-               showb = if bt `expLike` dt then [] else [AlwaysShow] in-               (PApp fc (PRef fc eqTy) [(pimp (sUN "A") at' True)-                                               { argopts = showa },-                                        (pimp (sUN "B") bt' True)-                                               { argopts = showb },-                                        pexp a', pexp b'],-                PApp fc (PRef fc eqTy) [(pimp (sUN "A") ct' True)-                                               { argopts = showa },-                                        (pimp (sUN "B") dt' True)-                                               { argopts = showb },-                                        pexp c', pexp d'])-+               (PPi p n fc a' b', PPi p' n' fc' c' d')     addI (PPair fc pi a b) (PPair fc' pi' c d)          = let (a', c') = addI a c                (b', d') = addI b d in@@ -503,15 +498,12 @@     expLike (PApp _ f as) (PApp _ f' as')         = expLike f f' && length as == length as' &&           and (zipWith expLike (getExps as) (getExps as'))-    expLike (PPi _ n s t) (PPi _ n' s' t')+    expLike (PPi _ n fc s t) (PPi _ n' fc' s' t')         = n == n' && expLike s s' && expLike t t'-    expLike (PLam _ n s t) (PLam _ n' s' t')+    expLike (PLam _ n _ s t) (PLam _ n' _ s' t')         = n == n' && expLike s s' && expLike t t'     expLike (PPair _ _ x y) (PPair _ _ x' y') = expLike x x' && expLike y y'     expLike (PDPair _ _ x _ y) (PDPair _ _ x' _ y') = expLike x x' && expLike y y'-    expLike (PEq _ xt yt x y) (PEq _ xt' yt' x' y')-         = expLike x x' && expLike y y'-    expLike (PRefl _ x) (PRefl _ x') = expLike x x'     expLike x y = x == y  -- Issue #1589 on the issue tracker@@ -533,8 +525,9 @@ annTm :: Term -> Doc OutputAnnotation -> Doc OutputAnnotation annTm tm = annotate (AnnTerm [] tm) -fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation-fancifyAnnots ist annot@(AnnName n _ _ _) =+-- | Add extra metadata to an output annotation, optionally marking metavariables.+fancifyAnnots :: IState -> Bool -> OutputAnnotation -> OutputAnnotation+fancifyAnnots ist meta annot@(AnnName n _ _ _) =   do let ctxt = tt_ctxt ist          docs = docOverview ist n          ty   = Just (getTy ist n)@@ -542,7 +535,9 @@        _ | isDConName      n ctxt -> AnnName n (Just DataOutput) docs ty        _ | isFnName        n ctxt -> AnnName n (Just FunOutput) docs ty        _ | isTConName      n ctxt -> AnnName n (Just TypeOutput) docs ty-       _ | isMetavarName   n ist  -> AnnName n (Just MetavarOutput) docs ty+       _ | isMetavarName   n ist  -> if meta+                                       then AnnName n (Just MetavarOutput) docs ty+                                       else AnnName n (Just FunOutput) docs ty        _ | isPostulateName n ist  -> AnnName n (Just PostulateOutput) docs ty        _ | otherwise              -> annot   where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs@@ -560,7 +555,7 @@         getTy ist n = let theTy = pprintPTerm (ppOptionIst ist) [] [] (idris_infixes ist) $                                   delabTy ist n                       in (displayS . renderPretty 1.0 50 $ theTy) ""-fancifyAnnots _ annot = annot+fancifyAnnots _ _ annot = annot  showSc :: IState -> [(Name, Term)] -> Doc OutputAnnotation showSc i [] = empty
+ src/Idris/Directives.hs view
@@ -0,0 +1,65 @@++module Idris.Directives where++import Idris.AbsSyntax+import Idris.ASTUtils+import Idris.Imports++import Idris.Core.Evaluate+import Idris.Core.TT++import Util.DynamicLinker++-- | Run the action corresponding to a directive+directiveAction :: Directive -> Idris ()+directiveAction (DLib cgn lib) = do addLib cgn lib+                                    addIBC (IBCLib cgn lib)++directiveAction (DLink cgn obj) = do dirs <- allImportDirs+                                     o <- runIO $ findInPath dirs obj+                                     addIBC (IBCObj cgn obj) -- just name, search on loading ibc+                                     addObjectFile cgn o++directiveAction (DFlag cgn flag) = do addIBC (IBCCGFlag cgn flag)+                                      addFlag cgn flag++directiveAction (DInclude cgn hdr) = do addHdr cgn hdr+                                        addIBC (IBCHeader cgn hdr)++directiveAction (DHide n) = do setAccessibility n Hidden+                               addIBC (IBCAccess n Hidden)++directiveAction (DFreeze n) = do setAccessibility n Frozen+                                 addIBC (IBCAccess n Frozen)++directiveAction (DAccess acc) = do updateIState (\i -> i { default_access = acc })++directiveAction (DDefault tot) =  do updateIState (\i -> i { default_total = tot })++directiveAction (DLogging lvl) = setLogLevel (fromInteger lvl)++directiveAction (DDynamicLibs libs) = do added <- addDyLib libs+                                         case added of+                                             Left lib -> addIBC (IBCDyLib (lib_name lib))+                                             Right msg -> fail $ msg++directiveAction (DNameHint ty ns) = do ty' <- disambiguate ty+                                       mapM_ (addNameHint ty') ns+                                       mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns++directiveAction (DErrorHandlers fn arg ns) = do fn' <- disambiguate fn+                                                ns' <- mapM disambiguate ns+                                                addFunctionErrorHandlers fn' arg ns'+                                                mapM_ (addIBC .+                                                    IBCFunctionErrorHandler fn' arg) ns'++directiveAction (DLanguage ext) = addLangExt ext++directiveAction (DUsed fc fn arg) = addUsedName fc fn arg++disambiguate :: Name -> Idris Name+disambiguate n = do i <- getIState+                    case lookupCtxtName n (idris_implicits i) of+                              [(n', _)] -> return n'+                              []        -> throwError (NoSuchVariable n)+                              more      -> throwError (CantResolveAlts (map fst more))
src/Idris/Docs.hs view
@@ -11,6 +11,8 @@  import Util.Pretty +import Prelude hiding ((<$>))+ import Control.Arrow (first)  import Data.Maybe@@ -38,6 +40,7 @@                         [(Maybe Name, PTerm, (d, [(Name, d)]))] -- instances: name for named instances, the constraint term, the docs                         [PTerm] -- subclasses                         [PTerm] -- superclasses+                        (Maybe (FunDoc' d)) -- explicit constructor              | NamedInstanceDoc Name (FunDoc' d) -- name is class              | ModDoc [String] -- Module name                       d@@ -93,7 +96,7 @@              if null args then text "No constructors."              else nest 4 (text "Constructors:" <> line <>                           vsep (map (pprintFD ist) args))-pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses)+pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses ctor)            = nest 4 (text "Type class" <+> prettyName True (ppopt_impl ppo) [] n <>                      if nullDocstring doc                        then empty@@ -104,6 +107,12 @@              nest 4 (text "Methods:" <$>                       vsep (map (pprintFD ist) meths))              <$>+             maybe empty+                   ((<> line) . nest 4 .+                    (text "Instance constructor:" <$>) .+                    pprintFD ist)+                   ctor+             <>              nest 4 (text "Instances:" <$>                        vsep (if null instances then [text "<no instances>"]                              else map pprintInstance normalInstances))@@ -161,8 +170,8 @@     dumpInstance :: PTerm -> Doc OutputAnnotation     dumpInstance = pprintPTerm ppo params' [] infixes -    prettifySubclasses (PPi (Constraint _ _) _ tm _)   = prettifySubclasses tm-    prettifySubclasses (PPi plcity           nm t1 t2) = PPi plcity (safeHead nm pNames) (prettifySubclasses t1) (prettifySubclasses t2)+    prettifySubclasses (PPi (Constraint _ _) _ _ tm _)   = prettifySubclasses tm+    prettifySubclasses (PPi plcity           nm fc t1 t2) = PPi plcity (safeHead nm pNames) NoFC (prettifySubclasses t1) (prettifySubclasses t2)     prettifySubclasses (PApp fc ref args)              = PApp fc ref $ updateArgs pNames args     prettifySubclasses tm                              = tm @@ -176,8 +185,8 @@     updateRef nm (PRef fc _) = PRef fc nm     updateRef _  pt          = pt -    isSubclass (PPi (Constraint _ _) _ (PApp _ _ args) (PApp _ (PRef _ nm) args')) = nm == n && map getTm args == map getTm args'-    isSubclass (PPi _                _ _ pt)                                       = isSubclass pt+    isSubclass (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ nm) args')) = nm == n && map getTm args == map getTm args'+    isSubclass (PPi _   _            _ _ pt)                                       = isSubclass pt     isSubclass _                                                                   = False      prettyParameters =@@ -223,7 +232,7 @@         classNameForInst ist n =           listToMaybe [ cn                       | (cn, ci) <- toAlist (idris_classes ist)-                      , n `elem` class_instances ci+                      , n `elem` map fst (class_instances ci)                       ]  docData :: Name -> TypeInfo -> Idris Docs@@ -245,24 +254,29 @@            instances = map (\inst -> (namedInst inst,                                       delabTy i inst,                                       docsForInstance inst))-                           (nub (class_instances ci))+                           (nub (map fst (class_instances ci)))            (subclasses, instances') = partition (isSubclass . (\(_,tm,_) -> tm)) instances            superclasses = catMaybes $ map getDInst (class_default_superclasses ci)        mdocs <- mapM (docFun . fst) (class_methods ci)+       let ctorN = instanceCtorName ci+       ctorDocs <- case basename ctorN of+                     SN _ -> return Nothing+                     _    -> fmap Just $ docFun ctorN        return $ ClassDoc                   n docstr mdocs params                   instances' (map (\(_,tm,_) -> tm) subclasses) superclasses+                  ctorDocs   where     namedInst (NS n ns) = fmap (flip NS ns) (namedInst n)     namedInst n@(UN _)  = Just n     namedInst _         = Nothing     -    getDInst (PInstance _ _ _ _ _ _ _ t _ _) = Just t-    getDInst _                           = Nothing+    getDInst (PInstance _ _ _ _ _ _ _ _ t _ _) = Just t+    getDInst _                                 = Nothing -    isSubclass (PPi (Constraint _ _) _ (PApp _ _ args) (PApp _ (PRef _ nm) args'))+    isSubclass (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ nm) args'))       = nm == n && map getTm args == map getTm args'-    isSubclass (PPi _ _ _ pt)+    isSubclass (PPi _ _ _ _ pt)       = isSubclass pt     isSubclass _       = False@@ -288,18 +302,18 @@              funName n        = show n  getPArgNames :: PTerm -> [(Name, Docstring DocTerm)] -> [(Name, PTerm, Plicity, Maybe (Docstring DocTerm))]-getPArgNames (PPi plicity name ty body) ds =+getPArgNames (PPi plicity name _ ty body) ds =   (name, ty, plicity, lookup name ds) : getPArgNames body ds getPArgNames _ _ = []  pprintConstDocs :: IState -> Const -> String -> Doc OutputAnnotation pprintConstDocs ist c str = text "Primitive" <+> text (if constIsType c then "type" else "value") <+>-                            pprintPTerm (ppOptionIst ist) [] [] [] (PConstant c) <+> colon <+>+                            pprintPTerm (ppOptionIst ist) [] [] [] (PConstant NoFC c) <+> colon <+>                             pprintPTerm (ppOptionIst ist) [] [] [] (t c) <>                             nest 4 (line <> text str) -  where t (Fl _)  = PConstant $ AType ATFloat-        t (BI _)  = PConstant $ AType (ATInt ITBig)-        t (Str _) = PConstant StrType-        t (Ch c)  = PConstant $ AType (ATInt ITChar)-        t _       = PType+  where t (Fl _)  = PConstant NoFC $ AType ATFloat+        t (BI _)  = PConstant NoFC $ AType (ATInt ITBig)+        t (Str _) = PConstant NoFC StrType+        t (Ch c)  = PConstant NoFC $ AType (ATInt ITChar)+        t _       = PType NoFC
src/Idris/Docstrings.hs view
@@ -15,6 +15,8 @@  import Idris.Core.TT (OutputAnnotation(..), TextFormatting(..), Name, Term, Err) +import Prelude hiding ((<$>))+ import qualified Data.Text as T import qualified Data.Foldable as F import Data.Foldable (Foldable)
src/Idris/Elab/AsPat.hs view
@@ -17,7 +17,7 @@     bindPats :: [(Name, FC, PTerm)] -> PTerm -> PTerm     bindPats [] rhs = rhs     bindPats ((n, fc, tm) : ps) rhs-       = PLet fc n Placeholder tm (bindPats ps rhs)+       = PLet fc n NoFC Placeholder tm (bindPats ps rhs)  collectAs :: PTerm -> State [(Name, FC, PTerm)] PTerm collectAs (PAs fc n tm) = do tm' <- collectAs tm
src/Idris/Elab/Class.hs view
@@ -7,7 +7,7 @@ import Idris.Error import Idris.Delaborate import Idris.Imports-import Idris.ElabTerm+import Idris.Elab.Term import Idris.Coverage import Idris.DataOpts import Idris.Providers@@ -15,7 +15,7 @@ import Idris.Inliner import Idris.PartialEval import Idris.DeepSeq-import Idris.Output (iputStrLn, pshow, iWarn)+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting) import IRTS.Lang  import Idris.Elab.Type@@ -54,15 +54,22 @@  elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->              FC -> [(Name, PTerm)] ->-             Name -> [(Name, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> -             [Name] -> [PDecl] -> Idris ()-elabClass info syn_in doc fc constraints tn ps pDocs fds ds-    = do let cn = SN (InstanceCtorN tn) -- sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)-         let tty = pibind ps PType+             Name -> FC -> [(Name, FC, PTerm)] -> [(Name, Docstring (Either Err PTerm))] ->+             [(Name, FC)] {- ^ determining params -} ->+             [PDecl] {- ^ class body -} ->+             Maybe (Name, FC) {- ^ instance ctor name and location -} ->+             Docstring (Either Err PTerm) {- ^ instance ctor docs -} ->+             Idris ()+elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd+    = do let cn = fromMaybe (SN (InstanceCtorN tn)) (fst <$> mcn)+         let tty = pibind (map (\(n, _, ty) -> (n, ty)) ps) (PType fc)          let constraint = PApp fc (PRef fc tn)-                                  (map (pexp . PRef fc) (map fst ps))+                                  (map (pexp . PRef fc) (map (\(n, _, _) -> n) ps)) -         let syn = syn_in { using = addToUsing (using syn_in) ps }+         let syn =+              syn_in { using = addToUsing (using syn_in)+                                 [(pn, pt) | (pn, _, pt) <- ps]+                     }           -- build data declaration          let mdecls = filter tydecl ds -- method declarations@@ -74,20 +81,22 @@          defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint)                       (filter clause ds)          let (methods, imethods)-              = unzip (map (\ ( x,y,z) -> (x, y)) ims)+              = unzip (map (\ (x, y, z) -> (x, y)) ims)          let defaults = map (\ (x, (y, z)) -> (x,y)) defs          -- build instance constructor type-         let cty = impbind ps $ conbind constraints+         let cty = impbind [(pn, pt) | (pn, _, pt) <- ps] $ conbind constraints                       $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)                                constraint-         let cons = [(emptyDocstring, [], cn, cty, fc, [])]-         let ddecl = PDatadecl tn tty cons++         let cons = [(cd, pDocs ++ mapMaybe memberDocs ds, cn, NoFC, cty, fc, [])]+         let ddecl = PDatadecl tn NoFC tty cons+          logLvl 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)          -- Elaborate the data declaration          elabData info (syn { no_imp = no_imp syn ++ mnames,                               imp_methods = mnames }) doc pDocs fc [] ddecl-         dets <- findDets cn fds-         addClass tn (CI cn (map nodoc imethods) defaults idecls (map fst ps) [] dets)+         dets <- findDets cn (map fst fds)+         addClass tn (CI cn (map nodoc imethods) defaults idecls (map (\(n, _, _) -> n) ps) [] dets)           -- for each constraint, build a top level function to chase it          cfns <- mapM (cfun cn constraint syn (map fst imethods)) constraints@@ -103,11 +112,26 @@          -- add the default definitions          mapM_ (rec_elabDecl info EAll info) (concat (map (snd.snd) defs))          addIBC (IBCClass tn)++         sendHighlighting $+           [(tnfc, AnnName tn Nothing Nothing Nothing)] +++           [(pnfc, AnnBoundName pn False) | (pn, pnfc, _) <- ps] +++           [(fdfc, AnnBoundName fc False) | (fc, fdfc) <- fds] +++           maybe [] (\(conN, conNFC) -> [(conNFC, AnnName conN Nothing Nothing Nothing)]) mcn+              where-    nodoc (n, (_, o, t)) = (n, (o, t))+    nodoc (n, (_, _, o, t)) = (n, (o, t))+     pibind [] x = x-    pibind ((n, ty): ns) x = PPi expl n ty (pibind ns x)+    pibind ((n, ty): ns) x = PPi expl n NoFC ty (pibind ns (chkUniq ty x)) +    -- To make sure the type constructor of the class is in the appropriate+    -- uniqueness hierarchy+    chkUniq u@(PUniverse _) (PType _) = u+    chkUniq (PUniverse l) (PUniverse r) = PUniverse (min l r)+    chkUniq (PPi _ _ _ _ sc) t = chkUniq sc t+    chkUniq _ t = t+     mdec :: Name -> Name     mdec (UN n) = SN (MethodN (UN n))     mdec (NS x n) = NS (mdec x) n@@ -115,7 +139,7 @@      -- TODO: probably should normalise     checkDefaultSuperclassInstance :: PDecl -> Idris ()-    checkDefaultSuperclassInstance (PInstance _ _ _ fc cs n ps _ _ _)+    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@@ -127,40 +151,41 @@      impbind :: [(Name, PTerm)] -> PTerm -> PTerm     impbind [] x = x-    impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x)+    impbind ((n, ty): ns) x = PPi impl n NoFC ty (impbind ns x)      conbind :: [(Name, PTerm)] -> PTerm -> PTerm-    conbind ((c, ty) : ns) x = PPi constraint c ty (conbind ns x)+    conbind ((c, ty) : ns) x = PPi constraint c NoFC ty (conbind ns x)     conbind [] x = x -    getMName (PTy _ _ _ _ _ n _) = nsroot n-    tdecl allmeths (PTy doc _ syn _ o n t)-           = do t' <- implicit' info syn (map fst ps ++ allmeths) n t+    getMName (PTy _ _ _ _ _ n nfc _) = nsroot n+    tdecl allmeths (PTy doc _ syn _ o n nfc t)+           = do t' <- implicit' info syn (map (\(n, _, _) -> n) ps ++ allmeths) n t                 logLvl 2 $ "Method " ++ show n ++ " : " ++ showTmImpls t'-                return ( (n, (toExp (map fst ps) Exp t')),-                         (n, (doc, o, (toExp (map fst ps)-                                         (\ l s p -> Imp l s p Nothing) t'))),-                         (n, (syn, o, t) ) )+                return ( (n, (toExp (map (\(pn, _, _) -> pn) ps) Exp t')),+                         (n, (nfc, doc, o, (toExp (map (\(pn, _, _) -> pn) ps)+                                              (\ l s p -> Imp l s p Nothing) t'))),+                         (n, (nfc, syn, o, t) ) )     tdecl _ _ = ifail "Not allowed in a class declaration"      -- Create default definitions     defdecl mtys c d@(PClauses fc opts n cs) =         case lookup n mtys of-            Just (syn, o, ty) -> do let ty' = insertConstraint c ty-                                    let ds = map (decorateid defaultdec)-                                                 [PTy emptyDocstring [] syn fc [] n ty',-                                                  PClauses fc (o ++ opts) n cs]-                                    iLOG (show ds)-                                    return (n, ((defaultdec n, ds!!1), ds))+            Just (nfc, syn, o, ty) ->+              do let ty' = insertConstraint c ty+                 let ds = map (decorateid defaultdec)+                              [PTy emptyDocstring [] syn fc [] n nfc ty',+                               PClauses fc (o ++ opts) n cs]+                 iLOG (show ds)+                 return (n, ((defaultdec n, ds!!1), ds))             _ -> ifail $ show n ++ " is not a method"     defdecl _ _ _ = ifail "Can't happen (defdecl)"      defaultdec (UN n) = sUN ("default#" ++ str n)     defaultdec (NS n ns) = NS (defaultdec n) ns -    tydecl (PTy _ _ _ _ _ _ _) = True+    tydecl (PTy _ _ _ _ _ _ _ _) = True     tydecl _ = False-    instdecl (PInstance _ _ _ _ _ _ _ _ _ _) = True+    instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _) = True     instdecl _ = False     clause (PClauses _ _ _ _) = True     clause _ = False@@ -174,9 +199,9 @@              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 cnm c con-             iLOG (showTmImpls ty)-             iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs)+             let ty = PPi constraint cnm NoFC c con+             logLvl 2 ("Dictionary constraint: " ++ showTmImpls ty)+             logLvl 2 (showTmImpls lhs ++ " = " ++ showTmImpls rhs)              i <- getIState              let conn = case con of                             PRef _ n -> n@@ -184,31 +209,31 @@              let conn' = case lookupCtxtName conn (idris_classes i) of                                 [(n, _)] -> n                                 _ -> conn-             addInstance False conn' cfn-             addIBC (IBCInstance False conn' cfn)+             addInstance False True conn' cfn+             addIBC (IBCInstance False True conn' cfn) --              iputStrLn ("Added " ++ show (conn, cfn, ty))-             return [PTy emptyDocstring [] syn fc [] cfn ty,+             return [PTy emptyDocstring [] syn fc [] cfn NoFC ty,                      PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]      -- Generate a top level function which looks up a method in a given     -- dictionary (this is inlinable, always)-    tfun cn c syn all (m, (doc, o, ty))-        = do let ty' = insertConstraint c ty+    tfun cn c syn all (m, (mfc, doc, o, ty))+        = do let ty' = expandMethNS syn (insertConstraint c ty)              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 -> 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 (showTmImpls ty')+             logLvl 2 ("Top level type: " ++ showTmImpls ty')              iLOG (show (m, ty', capp, margs))-             iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs)-             return [PTy doc [] syn fc o m ty',+             logLvl 2 ("Definition: " ++ showTmImpls lhs ++ " = " ++ showTmImpls rhs)+             return [PTy doc [] syn fc o m mfc ty',                      PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]] -    getMArgs (PPi (Imp _ _ _ _) n ty sc) = IA n : getMArgs sc-    getMArgs (PPi (Exp _ _ _) n ty sc) = EA n : getMArgs sc-    getMArgs (PPi (Constraint _ _) n ty sc) = CA : getMArgs sc+    getMArgs (PPi (Imp _ _ _ _) n _ ty sc) = IA n : getMArgs sc+    getMArgs (PPi (Exp _ _ _) n _ ty sc) = EA n : getMArgs sc+    getMArgs (PPi (Constraint _ _) n _ ty sc) = CA : getMArgs sc     getMArgs _ = []      getMeth (m:ms) (a:as) x | x == a = PRef fc m@@ -224,17 +249,35 @@     rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns     rhsArgs [] _ = [] -    insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)-                          = PPi p n ty (insertConstraint c sc)+    insertConstraint c (PPi p@(Imp _ _ _ _) n fc ty sc)+                          = PPi p n fc ty (insertConstraint c sc)     insertConstraint c sc = PPi (constraint { pstatic = Static })-                                  (sMN 0 "class") c sc+                                  (sMN 0 "class") NoFC c sc      -- make arguments explicit and don't bind class parameters-    toExp ns e (PPi (Imp l s p _) n ty sc)+    toExp ns e (PPi (Imp l s p _) n fc ty sc)         | n `elem` ns = toExp ns e sc-        | otherwise = PPi (e l s p) n ty (toExp ns e sc)-    toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)+        | otherwise = PPi (e l s p) n fc ty (toExp ns e sc)+    toExp ns e (PPi p n fc ty sc) = PPi p n fc ty (toExp ns e sc)     toExp ns e sc = sc++memberDocs :: PDecl -> Maybe (Name, Docstring (Either Err PTerm))+memberDocs (PTy d _ _ _ _ n _ _) = Just (basename n, d)+memberDocs (PPostulate _ d _ _ _ n _) = Just (basename n, d)+memberDocs (PData d _ _ _ _ pdata) = Just (basename $ d_name pdata, d)+memberDocs (PRecord d _ _ _ n _ _ _ _ _ _ _ ) = Just (basename n, d)+memberDocs (PClass d _ _ _ n _ _ _ _ _ _ _) = Just (basename n, d)+memberDocs _ = Nothing+++-- In a top level type for a method, expand all the method names namespaces+-- so that we don't have to disambiguate later+expandMethNS :: SyntaxInfo +                -> PTerm -> PTerm+expandMethNS syn = mapPT expand+  where+    expand (PRef fc n) | n `elem` imp_methods syn = PRef fc $ expandNS syn n+    expand t = t  findDets :: Name -> [Name] -> Idris [Int] findDets n ns =
src/Idris/Elab/Clause.hs view
@@ -7,7 +7,7 @@ import Idris.Error import Idris.Delaborate import Idris.Imports-import Idris.ElabTerm+import Idris.Elab.Term import Idris.Coverage import Idris.DataOpts import Idris.Providers@@ -16,7 +16,7 @@ import Idris.PartialEval import Idris.Transforms import Idris.DeepSeq-import Idris.Output (iputStrLn, pshow, iWarn, iRenderResult)+import Idris.Output (iputStrLn, pshow, iWarn, iRenderResult, sendHighlighting) import IRTS.Lang  import Idris.Elab.AsPat@@ -374,7 +374,7 @@                 logLvl 2 $ show n ++ " transformation rule: " ++                            show rhs ++ " ==> " ++ show lhs -                elabType info defaultSyntax emptyDocstring [] fc opts newnm specTy+                elabType info defaultSyntax emptyDocstring [] fc opts newnm NoFC specTy                 let def = map (\(lhs, rhs) ->                                   PClause fc newnm lhs [] rhs [])                                (pe_clauses specdecl)    @@ -433,7 +433,7 @@             showArg _ = ""              qshow (Bind _ _ _) = "fn"-            qshow (App f a) = qshow f ++ qshow a+            qshow (App _ f a) = qshow f ++ qshow a             qshow (P _ n _) = show n             qshow (Constant c) = show c             qshow _ = ""@@ -444,72 +444,29 @@             qhash hash [] = showHex (abs hash `mod` 0xffffffff) ""             qhash hash (x:xs) = qhash (hash * 33 + fromEnum x) xs --- checks if the clause is a possible left hand side. Returns the term if--- possible, otherwise Nothing.-+-- | Checks if the clause is a possible left hand side. checkPossible :: ElabInfo -> FC -> Bool -> Name -> PTerm -> Idris Bool checkPossible info fc tcgen fname lhs_in    = do ctxt <- getContext         i <- getIState         let lhs = addImplPat i lhs_in         -- if the LHS type checks, it is possible-        case elaborate ctxt (sMN 0 "patLHS") infP initEState+        case elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState                             (erun fc (buildTC i info ELHS [] fname (infTerm lhs))) of-            OK (ElabResult lhs' _ _ ctxt' newDecls, _) ->+            OK (ElabResult lhs' _ _ ctxt' newDecls highlights, _) ->                do setContext ctxt'-                  processTacticDecls newDecls+                  processTacticDecls info newDecls+                  sendHighlighting highlights                   let lhs_tm = orderPats (getInferTerm lhs')                   case recheck ctxt [] (forget lhs_tm) lhs_tm of                        OK _ -> return True                        err -> return False             -- if it's a recoverable error, the case may become possible-            Error err -> if tcgen then return (recoverable ctxt err)-                                  else return (validCase ctxt err ||-                                                 recoverable ctxt err)-    where validCase ctxt (CantUnify _ (topx, _) (topy, _) e _ _)-              = let topx' = normalise ctxt [] topx-                    topy' = normalise ctxt [] topy in-                    not (sameFam topx' topy' || not (validCase ctxt e))-          validCase ctxt (CantConvert _ _ _) = False-          validCase ctxt (At _ e) = validCase ctxt e-          validCase ctxt (Elaborating _ _ e) = validCase ctxt e-          validCase ctxt (ElaboratingArg _ _ _ e) = validCase ctxt e-          validCase ctxt _ = True+            Error err -> if tcgen then return (recoverableCoverage ctxt err)+                                  else return (validCoverageCase ctxt err ||+                                                 recoverableCoverage ctxt err) -          recoverable ctxt (CantUnify r (topx, _) (topy, _) e _ _)-              = let topx' = normalise ctxt [] topx-                    topy' = normalise ctxt [] topy in-                    checkRec topx' topy'-          recoverable ctxt (At _ e) = recoverable ctxt e-          recoverable ctxt (Elaborating _ _ e) = recoverable ctxt e-          recoverable ctxt (ElaboratingArg _ _ _ e) = recoverable ctxt e-          recoverable _ _ = False -          sameFam topx topy-              = case (unApply topx, unApply topy) of-                     ((P _ x _, _), (P _ y _, _)) -> x == y-                     _ -> False--          -- different notion of recoverable than in unification, since we-          -- have no metavars -- just looking to see if a constructor is failing-          -- to unify with a function that may be reduced later--          checkRec (App f a) p@(P _ _ _) = checkRec f p-          checkRec p@(P _ _ _) (App f a) = checkRec p f-          checkRec fa@(App _ _) fa'@(App _ _)-              | (f, as) <- unApply fa,-                (f', as') <- unApply fa'-                   = if (length as /= length as')-                        then checkRec f f'-                        else checkRec f f' && and (zipWith checkRec as as')-          checkRec (P xt x _) (P yt y _) = x == y || ntRec xt yt-          checkRec _ _ = False--          ntRec x y | Ref <- x = True-                    | Ref <- y = True-                    | (Bound, Bound) <- (x, y) = True-                    | otherwise = False -- name is different, unrecoverable- propagateParams :: IState -> [Name] -> Type -> PTerm -> PTerm propagateParams i ps t tm@(PApp _ (PRef fc n) args)      = PApp fc (PRef fc n) (addP t args)@@ -581,15 +538,17 @@         logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++                   "\n" ++ show (fn_ty, fn_is)) -        ((ElabResult lhs' dlhs [] ctxt' newDecls, probs, inj), _) <--           tclift $ elaborate ctxt (sMN 0 "patLHS") infP initEState+        ((ElabResult lhs' dlhs [] ctxt' newDecls highlights, probs, inj), _) <-+           tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState                     (do res <- errAt "left hand side of " fname                                  (erun fc (buildTC i info ELHS opts fname (infTerm lhs)))                         probs <- get_probs                         inj <- get_inj                         return (res, probs, inj))         setContext ctxt'-        processTacticDecls newDecls+        processTacticDecls info newDecls+        sendHighlighting highlights+                 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)          let lhs_tm = orderPats (getInferTerm lhs')@@ -656,25 +615,28 @@         logLvl 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs         ctxt <- getContext -- new context with where block added         logLvl 5 "STARTING CHECK"-        ((rhs', defer, is, probs, ctxt', newDecls), _) <--           tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty initEState+        ((rhs', defer, is, probs, ctxt', newDecls, highlights), _) <-+           tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patRHS") clhsty initEState                     (do pbinds ist lhs_tm                         mapM_ setinj (nub (params ++ inj))                         setNextName-                        (ElabResult _ _ is ctxt' newDecls) <- +                        (ElabResult _ _ is ctxt' newDecls highlights) <-                           errAt "right hand side of " fname                                 (erun fc (build i winfo ERHS opts fname rhs))                         errAt "right hand side of " fname                               (erun fc $ psolve lhs_tm)                         hs <- get_holes-                        aux <- getAux-                        mapM_ (elabCaseHole (case_decls aux)) hs+                        mapM_ (elabCaseHole is) hs                         tt <- get_term-                        let (tm, ds) = runState (collectDeferred (Just fname) tt) []+                        aux <- getAux+                        let (tm, ds) = runState (collectDeferred (Just fname) +                                                     (map fst $ case_decls aux) ctxt tt) []                         probs <- get_probs-                        return (tm, ds, is, probs, ctxt', newDecls))+                        return (tm, ds, is, probs, ctxt', newDecls, highlights))         setContext ctxt'-        processTacticDecls newDecls+        processTacticDecls info newDecls+        sendHighlighting highlights+         when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)          logLvl 5 "DONE CHECK"@@ -702,7 +664,7 @@         (crhs, crhsty) <- if not inf                              then recheckC_borrowing True borrowed fc id [] rhs'                              else return (rhs', clhsty)-        logLvl 6 $ " ==> " ++ show crhsty ++ "   against   " ++ show clhsty+        logLvl 6 $ " ==> " ++ showEnvDbg [] crhsty ++ "   against   " ++ showEnvDbg [] clhsty         ctxt <- getContext         let constv = next_tvar ctxt         case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of@@ -745,14 +707,14 @@     -- Find the variable names which appear under a 'Ownership.Read' so that     -- we know they can't be used on the RHS     borrowedNames :: [Name] -> Term -> [Name]-    borrowedNames env (App (App (P _ (NS (UN lend) [owner]) _) _) arg)+    borrowedNames env (App _ (App _ (P _ (NS (UN lend) [owner]) _) _) arg)         | owner == txt "Ownership" &&           (lend == txt "lend" || lend == txt "Read") = getVs arg        where          getVs (V i) = [env!!i]-         getVs (App f a) = nub $ getVs f ++ getVs a+         getVs (App _ f a) = nub $ getVs f ++ getVs a          getVs _ = []-    borrowedNames env (App f a) = nub $ borrowedNames env f ++ borrowedNames env a+    borrowedNames env (App _ f a) = nub $ borrowedNames env f ++ borrowedNames env a     borrowedNames env (Bind n b sc) = nub $ borrowedB b ++ borrowedNames (n:env) sc        where borrowedB (Let t v) = nub $ borrowedNames env t ++ borrowedNames env v              borrowedB b = borrowedNames env (binderTy b)@@ -770,7 +732,7 @@ --        = NS (UN ('#':show x)) [show cnum, show fname]      sepBlocks bs = sepBlocks' [] bs where-      sepBlocks' ns (d@(PTy _ _ _ _ _ n t) : bs)+      sepBlocks' ns (d@(PTy _ _ _ _ _ n _ t) : bs)             = let (bf, af) = sepBlocks' (n : ns) bs in                   (d : bf, af)       sepBlocks' ns (d@(PClauses _ _ n _) : bs)@@ -817,12 +779,14 @@         let params = getParamsInType i [] fn_is fn_ty         let lhs = stripLinear i $ stripUnmatchable i $ propagateParams i params fn_ty (addImplPat i lhs_in)         logLvl 2 ("LHS: " ++ show lhs)-        (ElabResult lhs' dlhs [] ctxt' newDecls, _) <--            tclift $ elaborate ctxt (sMN 0 "patLHS") infP initEState+        (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-+            tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState               (errAt "left hand side of with in " fname                 (erun fc (buildTC i info ELHS opts fname (infTerm lhs))) )         setContext ctxt'-        processTacticDecls newDecls+        processTacticDecls info newDecls+        sendHighlighting highlights+         let lhs_tm = orderPats (getInferTerm lhs')         let lhs_ty = getInferType lhs'         let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))@@ -834,19 +798,21 @@         let wval = addImplBound i (map fst bargs) wval_in         logLvl 5 ("Checking " ++ showTmImpls wval)         -- Elaborate wval in this context-        ((wval', defer, is, ctxt', newDecls), _) <--            tclift $ elaborate ctxt (sMN 0 "withRHS")+        ((wval', defer, is, ctxt', newDecls, highlights), _) <-+            tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "withRHS")                         (bindTyArgs PVTy bargs infP) initEState                         (do pbinds i lhs_tm                             setNextName                             -- TODO: may want where here - see winfo abpve-                            (ElabResult _ d is ctxt' newDecls) <- errAt "with value in " fname+                            (ElabResult _ d is ctxt' newDecls highlights) <- errAt "with value in " fname                               (erun fc (build i info ERHS opts fname (infTerm wval)))                             erun fc $ psolve lhs_tm                             tt <- get_term-                            return (tt, d, is, ctxt', newDecls))+                            return (tt, d, is, ctxt', newDecls, highlights))         setContext ctxt'-        processTacticDecls newDecls+        processTacticDecls info newDecls+        sendHighlighting highlights+         def' <- checkDef fc iderr defer         let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'         addDeferred def''@@ -861,7 +827,7 @@         -- so this doesn't lose anything)         case getArgTys cwvaltyN of              [] -> return ()-             (_:_) -> ierror $ At fc (WithFnType cwvalty)  +             (_:_) -> ierror $ At fc (WithFnType cwvalty)          let pvars = map fst (getPBtys cwvalty)         -- we need the unelaborated term to get the names it depends on@@ -871,8 +837,11 @@          let mpn = case pn_in of                        Nothing -> Nothing-                       Just n -> Just (uniqueName n (map fst bargs))+                       Just (n, nfc) -> Just (uniqueName n (map fst bargs)) +        -- Highlight explicit proofs+        sendHighlighting $ [(fc, AnnBoundName n False) | (n, fc) <- maybeToList pn_in]+         logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++                   " depends on " ++ show pdeps ++ " from " ++ show pvars)         logLvl 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post)@@ -928,20 +897,25 @@                     (map (pexp . (PRef fc) . fst) bargs_post) ++                     case mpn of                          Nothing -> []-                         Just _ -> [pexp (PRefl fc Placeholder)])+                         Just _ -> [pexp (PApp NoFC (PRef NoFC eqCon)+                                               [ pimp (sUN "A") Placeholder False+                                               , pimp (sUN "x") Placeholder False+                                               ])])         logLvl 5 ("New RHS " ++ showTmImpls rhs)         ctxt <- getContext -- New context with block added         i <- getIState-        ((rhs', defer, is, ctxt', newDecls), _) <--           tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty initEState+        ((rhs', defer, is, ctxt', newDecls, highlights), _) <-+           tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "wpatRHS") clhsty initEState                     (do pbinds i lhs_tm                         setNextName-                        (ElabResult _ d is ctxt' newDecls) <- erun fc (build i info ERHS opts fname rhs)+                        (ElabResult _ d is ctxt' newDecls highlights) <-+                           erun fc (build i info ERHS opts fname rhs)                         psolve lhs_tm                         tt <- get_term-                        return (tt, d, is, ctxt', newDecls))+                        return (tt, d, is, ctxt', newDecls, highlights))         setContext ctxt'-        processTacticDecls newDecls+        processTacticDecls info newDecls+        sendHighlighting highlights          def' <- checkDef fc iderr defer         let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'
src/Idris/Elab/Data.hs view
@@ -7,7 +7,7 @@ import Idris.Error import Idris.Delaborate import Idris.Imports-import Idris.ElabTerm+import Idris.Elab.Term import Idris.Coverage import Idris.DataOpts import Idris.Providers@@ -15,7 +15,7 @@ import Idris.Inliner import Idris.PartialEval import Idris.DeepSeq-import Idris.Output (iputStrLn, pshow, iWarn)+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting) import IRTS.Lang  import Idris.Elab.Type@@ -51,7 +51,7 @@ import Util.Pretty(pretty, text)  elabData :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm)-> [(Name, Docstring (Either Err PTerm))] -> FC -> DataOpts -> PData -> Idris ()-elabData info syn doc argDocs fc opts (PLaterdecl n t_in)+elabData info syn doc argDocs fc opts (PLaterdecl n nfc t_in)     = do let codata = Codata `elem` opts          iLOG (show (fc, doc))          checkUndefined fc n@@ -59,8 +59,9 @@           addIBC (IBCDef n)          updateContext (addTyDecl n (TCon 0 0) cty) -- temporary, to check cons+         sendHighlighting [(nfc, AnnName n Nothing Nothing Nothing)] -elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)+elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)     = do let codata = Codata `elem` opts          iLOG (show fc)          undef <- isUndefined fc n@@ -116,6 +117,11 @@          -- create a case function          when (DefaultCaseFun `elem` opts) $             evalStateT (elabCaseFun False params n t dcons info) Map.empty+         -- Emit highlighting info+         sendHighlighting $ [(nfc, AnnName n Nothing Nothing Nothing)] +++           map (\(_, _, n, nfc, _, _, _) ->+                 (nfc, AnnName n Nothing Nothing Nothing))+               dcons   where         setDetaggable :: Name -> Idris ()         setDetaggable n = do@@ -174,7 +180,7 @@             update ((n, _) : as) (_ : args) = (n, Nothing) : update as args          getDataApp :: Type -> [[Maybe Name]]-        getDataApp f@(App _ _)+        getDataApp f@(App _ _ _)             | (P _ d _, args) <- unApply f                    = if (d == n) then [mParam args args] else []         getDataApp (Bind n (Pi _ t _) sc)@@ -194,7 +200,7 @@                        | otherwise = count n ts         mParam args (_ : rest) = Nothing : mParam args rest -        cname (_, _, n, _, _, _) = n+        cname (_, _, n, _, _, _, _) = n          -- Abuse of ElabInfo.         -- TODO Contemplate whether the ElabInfo type needs modification.@@ -212,9 +218,9 @@ elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->            Type -> -- for unique kind checking            Type -> -- data type's kind-           (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name]) ->+           (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name]) ->            Idris (Name, Type)-elabCon info syn tn codata expkind dkind (doc, argDocs, n, t_in, fc, forcenames)+elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcenames)     = do checkUndefined fc n          logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t_in          (cty, ckind, t, inacc) <- buildType info syn fc [Constructor] n (if codata then mkLazy t_in else t_in)@@ -251,13 +257,13 @@              else return ()     tyIs con t = tclift $ tfail (At fc (Elaborating "constructor " con (Msg (show t ++ " is not " ++ show tn)))) -    mkLazy (PPi pl n ty sc)+    mkLazy (PPi pl n nfc ty sc)         = let ty' = if getTyName ty                        then PApp fc (PRef fc (sUN "Lazy'"))                             [pexp (PRef fc (sUN "LazyCodata")),                              pexp ty]                        else ty in-              PPi pl n ty' (mkLazy sc)+              PPi pl n nfc ty' (mkLazy sc)     mkLazy t = t      getTyName (PApp _ (PRef _ n) _) = n == nsroot tn@@ -266,12 +272,13 @@       getNamePos :: Int -> PTerm -> Name -> Maybe Int-    getNamePos i (PPi _ n _ sc) x | n == x = Just i-                                  | otherwise = getNamePos (i + 1) sc x+    getNamePos i (PPi _ n _ _ sc) x | n == x = Just i+                                    | otherwise = getNamePos (i + 1) sc x     getNamePos _ _ _ = Nothing      -- if the constructor is a UniqueType, the datatype must be too-    -- (Type* is fine, since that is checked for uniqueness too)+    -- (AnyType is fine, since that is checked for uniqueness too)+    -- if hte contructor is AnyType, the datatype must be at least AnyType     checkUniqueKind (UType NullType) (UType NullType) = return ()     checkUniqueKind (UType NullType) _         = tclift $ tfail (At fc (UniqueKindError NullType n))@@ -279,7 +286,10 @@     checkUniqueKind (UType UniqueType) (UType AllTypes) = return ()     checkUniqueKind (UType UniqueType) _         = tclift $ tfail (At fc (UniqueKindError UniqueType n))-    checkUniqueKind (UType AllTypes) _ = return ()+    checkUniqueKind (UType AllTypes) (UType AllTypes) = return ()+    checkUniqueKind (UType AllTypes) (UType UniqueType) = return ()+    checkUniqueKind (UType AllTypes) _ +        = tclift $ tfail (At fc (UniqueKindError AllTypes n))     checkUniqueKind _ _ = return ()      -- Constructor's kind must be <= expected kind@@ -298,17 +308,17 @@ -- FIXME: Many things have name starting with elim internally since this was the only purpose in the first edition of the function -- rename to caseFun to match updated intend elabCaseFun :: Bool -> [Int] -> Name -> PTerm ->-                  [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name])] ->+                  [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name])] ->                   ElabInfo -> EliminatorState () elabCaseFun ind paramPos n ty cons info = do   elimLog $ "Elaborating case function"-  put (Map.fromList $ zip (concatMap (\(_, p, _, ty, _, _) -> (map show $ boundNamesIn ty) ++ map (show . fst) p) cons ++ (map show $ boundNamesIn ty)) (repeat 0))+  put (Map.fromList $ zip (concatMap (\(_, p, _, _, ty, _, _) -> (map show $ boundNamesIn ty) ++ map (show . fst) p) cons ++ (map show $ boundNamesIn ty)) (repeat 0))   let (cnstrs, _) = splitPi ty   let (splittedTy@(pms, idxs)) = splitPms cnstrs   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                                let casefunt = if ind then "elim_" else "case_"                                name <- freshName $ casefunt ++ simpleName cnm                                consTerm <- extractConsTerm c generalParams@@ -317,7 +327,7 @@   let motiveConstr = [(motiveName, expl, motive)]   let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))   let eliminatorTy = piConstr (generalParams ++ motiveConstr ++ consTerms ++ scrutineeIdxs ++ [scrutinee]) (applyMotive (map (\(n,_,_) -> PRef elimFC n) scrutineeIdxs) (PRef elimFC scrutineeName))-  let eliminatorTyDecl = PTy (fmap (const (Left $ Msg "")) . parseDocstring . T.pack $ show n) [] defaultSyntax elimFC [TotalFn] elimDeclName eliminatorTy+  let eliminatorTyDecl = PTy (fmap (const (Left $ Msg "")) . parseDocstring . T.pack $ show n) [] defaultSyntax elimFC [TotalFn] elimDeclName NoFC eliminatorTy   let clauseConsElimArgs = map getPiName consTerms   let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs   let clauseGeneralArgs  = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'@@ -349,8 +359,8 @@         splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm)         splitPi = splitPi' []           where splitPi' :: [(Name, Plicity, PTerm)] -> PTerm -> ([(Name, Plicity, PTerm)], PTerm)-                splitPi' acc (PPi pl n tyl tyr) = splitPi' ((n, pl, tyl):acc) tyr-                splitPi' acc t                  = (reverse acc, t)+                splitPi' acc (PPi pl n _ tyl tyr) = splitPi' ((n, pl, tyl):acc) tyr+                splitPi' acc t                    = (reverse acc, t)          splitPms :: [(Name, Plicity, PTerm)] -> ([(Name, Plicity, PTerm)], [(Name, Plicity, PTerm)])         splitPms cnstrs = (map fst pms, map fst idxs)@@ -373,7 +383,7 @@           where keyOf :: PTerm -> String                 keyOf (PRef _ name) | isLetter (nameStart name) = (toLower $ nameStart name):"__"                 keyOf (PApp _ tyf _) = keyOf tyf-                keyOf PType = "ty__"+                keyOf (PType _) = "ty__"                 keyOf _     = "carg__"                 nameStart :: Name -> Char                 nameStart n = nameStart' (simpleName n)@@ -410,11 +420,11 @@         mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm         mkMotive n paramPos params indicies =           let scrutineeTy = (scrutineeArgName, expl, applyCons n (interlievePos paramPos params indicies 0))-          in piConstr (indicies ++ [scrutineeTy]) PType+          in piConstr (indicies ++ [scrutineeTy]) (PType elimFC)          piConstr :: [(Name, Plicity, PTerm)] -> PTerm -> PTerm         piConstr [] ty = ty-        piConstr ((n, pl, tyb):tyr) ty = PPi pl n tyb (piConstr tyr ty)+        piConstr ((n, pl, tyb):tyr) ty = PPi pl n NoFC tyb (piConstr tyr ty)          interlievePos :: [Int] -> [a] -> [a] -> Int -> [a]         interlievePos idxs []     l2     i = l2@@ -432,9 +442,9 @@                _ -> cns          removeParamPis :: [Name] -> [(Name, Plicity, PTerm)] -> PTerm -> PTerm-        removeParamPis oldParams params (PPi pl n tyb tyr) =+        removeParamPis oldParams params (PPi pl n fc tyb tyr) =           case findIndex (== n) oldParams of-            Nothing -> (PPi pl n (removeParamPis oldParams params tyb) (removeParamPis oldParams params tyr))+            Nothing -> (PPi pl n fc (removeParamPis oldParams params tyb) (removeParamPis oldParams params tyr))             Just i  -> (removeParamPis oldParams params tyr)         removeParamPis oldParams params (PRef _ n) =           case findIndex (== n) oldParams of@@ -484,8 +494,8 @@               in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs              _ -> return implargs -        extractConsTerm :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm-        extractConsTerm (doc, argDocs, cnm, ty, fc, fs) generalParameters = do+        extractConsTerm :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm+        extractConsTerm (doc, argDocs, cnm, _, ty, fc, fs) generalParameters = do           let cons' = replaceParams paramPos generalParameters ty           let (args, resTy) = splitPi cons'           implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)@@ -520,8 +530,8 @@         convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)         convertImplPi _                             = Nothing -        generateEliminatorClauses :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause-        generateEliminatorClauses (doc, _, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do+        generateEliminatorClauses :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, 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 <- State.lift getIState
src/Idris/Elab/Instance.hs view
@@ -7,7 +7,6 @@ import Idris.Error import Idris.Delaborate import Idris.Imports-import Idris.ElabTerm import Idris.Coverage import Idris.DataOpts import Idris.Providers@@ -15,12 +14,13 @@ import Idris.Inliner import Idris.PartialEval import Idris.DeepSeq-import Idris.Output (iputStrLn, pshow, iWarn)+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting) import IRTS.Lang  import Idris.Elab.Type import Idris.Elab.Data import Idris.Elab.Utils+import Idris.Elab.Term  import Idris.Core.TT import Idris.Core.Elaborate hiding (Tactic(..))@@ -56,11 +56,12 @@                 ElabWhat -> -- phase                 FC -> [(Name, PTerm)] -> -- constraints                 Name -> -- the class+                FC -> -- precise location of class name                 [PTerm] -> -- class parameters (i.e. instance)                 PTerm -> -- full instance type                 Maybe Name -> -- explicit name                 [PDecl] -> Idris ()-elabInstance info syn doc argDocs what fc cs n ps t expn ds = do+elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do     i <- getIState     (n, ci) <- case lookupCtxtName n (idris_classes i) of                   [c] -> return c@@ -71,14 +72,14 @@     let iname = mkiname n (namespace info) ps expn     let emptyclass = null (class_methods ci)     when (what /= EDefns || (null ds && not emptyclass)) $ do-         nty <- elabType' True info syn doc argDocs fc [] iname t+         nty <- elabType' True info syn doc argDocs fc [] iname NoFC 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_ (maybe (return ()) overlapping . findOverlapping i (class_determiners ci) (delab i nty))-                                (class_instances ci)-                          addInstance intInst n iname-            Just _ -> addInstance intInst n iname+                                (map fst $ class_instances ci)+                          addInstance intInst True n iname+            Just _ -> addInstance intInst False n iname     when (what /= ETypes && (not (null ds && not emptyclass))) $ do          let ips = zip (class_params ci) ps          let ns = case n of@@ -90,7 +91,9 @@                                   PApp _ _ args -> getWParams (map getTm args)                                   a@(PRef fc f) -> getWParams [a]                                   _ -> return []) ps-         let pnames = map pname (concat (nub wparams))+         ist <- getIState+         let pnames = nub $ map pname (concat (nub wparams)) +++                          concatMap (namesIn [] ist) ps          let superclassInstances = map (substInstance ips pnames) (class_default_superclasses ci)          undefinedSuperclassInstances <- filterM (fmap not . isOverlapping i) superclassInstances          mapM_ (rec_elabDecl info EAll info) undefinedSuperclassInstances@@ -119,7 +122,6 @@                                       show (concat (nub wparams))           -- Bring variables in instance head into scope-         ist <- getIState          let headVars = nub $ mapMaybe (\p -> case p of                                                PRef _ n ->                                                   case lookupTy n (tt_ctxt ist) of@@ -129,7 +131,7 @@ --          let lhs = PRef fc iname          let lhs = PApp fc (PRef fc iname)                            (map (\n -> pimp n (PRef fc n) True) headVars)-         let rhs = PApp fc (PRef fc (instanceName ci))+         let rhs = PApp fc (PRef fc (instanceCtorName ci))                            (map (pexp . mkMethApp) mtys)           logLvl 5 $ "Instance LHS " ++ show lhs ++ " " ++ show headVars@@ -141,11 +143,11 @@          mapM_ (rec_elabDecl info EAll info) idecls          ist <- getIState          checkInjectiveArgs fc n (class_determiners ci) (lookupTyExact iname (tt_ctxt ist))-         addIBC (IBCInstance intInst n iname)+         addIBC (IBCInstance intInst (isNothing expn) n iname)    where     intInst = case ps of-                [PConstant (AType (ATInt ITNative))] -> True+                [PConstant NoFC (AType (ATInt ITNative))] -> True                 _ -> False      mkiname n' ns ps' expn' =@@ -155,10 +157,10 @@                           Just m -> sNS (SN (sInstanceN n' (map show ps'))) m           Just nm -> nm -    substInstance ips pnames (PInstance doc argDocs syn _ cs n ps t expn ds)-        = PInstance doc argDocs syn fc cs n (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds+    substInstance ips pnames (PInstance doc argDocs syn _ cs n nfc ps t expn ds)+        = PInstance doc argDocs syn fc cs n nfc (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds -    isOverlapping i (PInstance doc argDocs syn _ _ n ps t expn _)+    isOverlapping i (PInstance doc argDocs syn _ _ n nfc ps t expn _)         = case lookupCtxtName n (idris_classes i) of             [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in                             case lookupTy iname (tt_ctxt i) of@@ -175,15 +177,16 @@              ty' <- implicit info syn iname ty'              let ty = addImpl [] i ty'              ctxt <- getContext-             (ElabResult tyT _ _ ctxt' newDecls, _) <--                tclift $ elaborate ctxt iname (TType (UVal 0)) initEState+             (ElabResult tyT _ _ ctxt' newDecls highlights, _) <-+                tclift $ elaborate ctxt (idris_datatypes i) iname (TType (UVal 0)) initEState                          (errAt "type of " iname (erun fc (build i info ERHS [] iname ty)))              setContext ctxt'-             processTacticDecls newDecls+             processTacticDecls info newDecls+             sendHighlighting highlights              ctxt <- getContext              (cty, _) <- recheckC fc id [] tyT              let nty = normalise ctxt [] cty-             return $ any (isJust . findOverlapping i (class_determiners ci) (delab i nty)) (class_instances ci)+             return $ any (isJust . findOverlapping i (class_determiners ci) (delab i nty)) (map fst $ class_instances ci)      findOverlapping i dets t n      | take 2 (show n) == "@@" = Nothing@@ -199,7 +202,7 @@             _ -> Nothing     overlapping t' = tclift $ tfail (At fc (Msg $                           "Overlapping instance: " ++ show t' ++ " already defined"))-    getRetType (PPi _ _ _ sc) = getRetType sc+    getRetType (PPi _ _ _ _ sc) = getRetType sc     getRetType t = t      matchArgs i dets x y =@@ -214,16 +217,16 @@      mkMethApp (n, _, _, ty)           = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))-    lamBind i (PPi (Constraint _ _) _ _ sc) sc'-          = PLam fc (sMN i "meth") Placeholder (lamBind (i+1) sc sc')-    lamBind i (PPi _ n ty sc) sc'-          = PLam fc (sMN i "meth") Placeholder (lamBind (i+1) sc sc')+    lamBind i (PPi (Constraint _ _) _ _ _ sc) sc'+          = PLam fc (sMN i "meth") NoFC Placeholder (lamBind (i+1) sc sc')+    lamBind i (PPi _ n _ ty sc) sc'+          = PLam fc (sMN i "meth") NoFC Placeholder (lamBind (i+1) sc sc')     lamBind i _ sc = sc-    methArgs i (PPi (Imp _ _ _ _) n ty sc)+    methArgs i (PPi (Imp _ _ _ _) n _ ty sc)         = PImp 0 True [] n (PRef fc (sMN i "meth")) : methArgs (i+1) sc-    methArgs i (PPi (Exp _ _ _) n ty sc)+    methArgs i (PPi (Exp _ _ _) n _ ty sc)         = PExp 0 [] (sMN 0 "marg") (PRef fc (sMN i "meth")) : methArgs (i+1) sc-    methArgs i (PPi (Constraint _ _) n ty sc)+    methArgs i (PPi (Constraint _ _) n _ ty sc)         = PConstraint 0 [] (sMN 0 "marg") (PResolveTC fc) : methArgs (i+1) sc     methArgs i _ = [] @@ -243,16 +246,16 @@     decorate ns iname (UN n)        = NS (SN (MethodN (UN n))) ns     decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns -    mkTyDecl (n, op, t, _) -        = PTy emptyDocstring [] syn fc op n +    mkTyDecl (n, op, t, _)+        = PTy emptyDocstring [] syn fc op n NoFC                (mkUniqueNames [] t)      conbind :: [(Name, PTerm)] -> PTerm -> PTerm-    conbind ((c,ty) : ns) x = PPi constraint c ty (conbind ns x)+    conbind ((c,ty) : ns) x = PPi constraint c NoFC ty (conbind ns x)     conbind [] x = x      coninsert :: [(Name, PTerm)] -> PTerm -> PTerm-    coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc)+    coninsert cs (PPi p@(Imp _ _ _ _) n fc t sc) = PPi p n fc t (coninsert cs sc)     coninsert cs sc = conbind cs sc      -- Reorder declarations to be in the same order as defined in the@@ -279,19 +282,19 @@        = insertDefaults i iname defs ns (insertDef i n dn clauses ns iname ds)      insertDef i meth def clauses ns iname decls-        | null $ filter (clauseFor meth iname ns) decls+        | not $ any (clauseFor meth iname ns) decls             = let newd = expandParamsD False i (\n -> meth) [] [def] clauses in                   -- trace (show newd) $                   decls ++ [newd]         | otherwise = decls      warnMissing decls ns iname meth-        | null $ filter (clauseFor meth iname ns) decls+        | not $ any (clauseFor meth iname ns) decls             = iWarn fc . text $ "method " ++ show meth ++ " not defined"         | otherwise = return ()      checkInClass ns meth-        | not (null (filter (eqRoot meth) ns)) = return ()+        | any (eqRoot meth) ns = return ()         | otherwise = tclift $ tfail (At fc (Msg $                                 show meth ++ " not a method of class " ++ show n)) @@ -316,7 +319,7 @@      isInj i (P Bound n _) = True      isInj i (P _ n _) = isConName n (tt_ctxt i)-    isInj i (App f a) = isInj i f && isInj i a+    isInj i (App _ f a) = isInj i f && isInj i a     isInj i (V _) = True     isInj i (Bind n b sc) = isInj i sc     isInj _ _ = True
src/Idris/Elab/Provider.hs view
@@ -7,7 +7,6 @@ import Idris.Error import Idris.Delaborate import Idris.Imports-import Idris.ElabTerm import Idris.Coverage import Idris.DataOpts import Idris.Providers@@ -22,6 +21,7 @@ import Idris.Elab.Clause import Idris.Elab.Value import Idris.Elab.Utils+import Idris.Elab.Term  import Idris.Core.TT import Idris.Core.Elaborate hiding (Tactic(..))@@ -66,7 +66,7 @@          -- The goal type for a postulate is always Type.          (ty', typ) <- case what of                          ProvTerm ty p   -> elabVal info ERHS ty-                         ProvPostulate _ -> elabVal info ERHS PType+                         ProvPostulate _ -> elabVal info ERHS (PType fc)          unless (isTType typ) $            ifail ("Expected a type, got " ++ show ty' ++ " : " ++ show typ) @@ -93,7 +93,7 @@            Provide tm              | ProvTerm ty _ <- what ->                do -- Finally add a top-level definition of the provided term-                  elabType info syn doc [] fc [] n ty+                  elabType info syn doc [] fc [] n NoFC ty                   elabClauses info fc [] n [PClause fc n (PApp fc (PRef fc n) []) [] (delab i tm) []]                   logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm              | ProvPostulate _ <- what ->@@ -111,8 +111,8 @@           -- (MkFFI C_FFI) (Providers.Provider ty) in hopes of better           -- error messages with less normalisation           providerOf :: Type -> Type-          providerOf ty = App (P Ref (sUN "IO") Erased) $-                            App (P Ref (sNS (sUN "Provider") ["Providers", "Prelude"]) Erased)+          providerOf ty = App Complete (P Ref (sUN "IO") Erased) $+                            App Complete (P Ref (sNS (sUN "Provider") ["Providers", "Prelude"]) Erased)                               ty            isProviderOf :: Context -> TT Name -> TT Name -> Bool
src/Idris/Elab/Record.hs view
@@ -1,13 +1,12 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, ViewPatterns #-} module Idris.Elab.Record(elabRecord) where  import Idris.AbsSyntax-import Idris.ASTUtils-import Idris.DSL+import Idris.Docstrings import Idris.Error import Idris.Delaborate import Idris.Imports-import Idris.ElabTerm+import Idris.Elab.Term import Idris.Coverage import Idris.DataOpts import Idris.Providers@@ -15,228 +14,443 @@ import Idris.Inliner import Idris.PartialEval import Idris.DeepSeq-import Idris.Output (iputStrLn, pshow, iWarn)+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting) import IRTS.Lang +import Idris.ParseExpr (tryFullExpr)+ import Idris.Elab.Type import Idris.Elab.Data import Idris.Elab.Utils  import Idris.Core.TT-import Idris.Core.Elaborate hiding (Tactic(..)) import Idris.Core.Evaluate-import Idris.Core.Execute-import Idris.Core.Typecheck-import Idris.Core.CaseTree -import Idris.Docstrings--import Prelude hiding (id, (.))-import Control.Category+import Idris.Elab.Data -import Control.Applicative hiding (Const)-import Control.DeepSeq-import Control.Monad-import Control.Monad.State.Strict as State-import Data.List import Data.Maybe-import Debug.Trace+import Data.List+import Control.Monad -import qualified Data.Map as Map-import qualified Data.Set as S-import qualified Data.Text as T-import Data.Char(isLetter, toLower)-import Data.List.Split (splitOn)+-- | Elaborate a record declaration+elabRecord :: ElabInfo+           -> (Docstring (Either Err PTerm)) -- ^ The documentation for the whole declaration+           -> SyntaxInfo -> FC -> DataOpts+           -> Name  -- ^ The name of the type being defined+           -> FC -- ^ The precise source location of the tycon name+           -> [(Name, FC, Plicity, PTerm)] -- ^ Parameters+           -> [(Name, Docstring (Either Err PTerm))] -- ^ Parameter Docs+           -> [(Maybe (Name, FC), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -- ^ Fields+           -> Maybe (Name, FC) -- ^ Constructor Name+           -> (Docstring (Either Err PTerm)) -- ^ Constructor Doc+           -> SyntaxInfo -- ^ Constructor SyntaxInfo+           -> Idris ()+elabRecord info doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc csyn+  = do logLvl 1 $ "Building data declaration for " ++ show tyn+       -- Type constructor+       let tycon = generateTyConType params+       logLvl 1 $ "Type constructor " ++ showTmImpls tycon+       +       -- Data constructor+       dconName <- generateDConName (fmap fst cname)+       let dconTy = generateDConType params fieldsWithNameAndDoc+       logLvl 1 $ "Data constructor: " ++ showTmImpls dconTy -import Util.Pretty(pretty, text)+       -- Build data declaration for elaboration+       iLOG $ foldr (++) "" $ intersperse "\n" (map show dconsArgDocs)+       let datadecl = PDatadecl tyn NoFC tycon [(cdoc, dconsArgDocs, dconName, NoFC, dconTy, fc, [])]+       elabData info rsyn doc paramDocs fc opts datadecl -elabRecord :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> FC -> Name ->-              PTerm -> DataOpts -> Docstring (Either Err PTerm) -> Name -> PTerm -> Idris ()-elabRecord info syn doc fc tyn ty opts cdoc cn cty_in-    = do elabData info syn doc [] fc opts (PDatadecl tyn ty [(cdoc, [], cn, cty_in, fc, [])])-         -- TODO think: something more in info?-         cty' <- implicit info syn cn cty_in-         i <- getIState+       iLOG $ "fieldsWithName " ++ show fieldsWithName+       iLOG $ "fieldsWIthNameAndDoc " ++ show fieldsWithNameAndDoc+       elabRecordFunctions info rsyn fc tyn paramsAndDoc fieldsWithNameAndDoc dconName target -         -- get bound implicits and propagate to setters (in case they-         -- provide useful information for inference)-         let extraImpls = getBoundImpls cty'+       sendHighlighting $+         [(nfc, AnnName tyn Nothing Nothing Nothing)] +++         maybe [] (\(_, cnfc) -> [(cnfc, AnnName dconName Nothing Nothing Nothing)]) cname +++         [(ffc, AnnBoundName fn False) | (fn, ffc, _, _, _) <- fieldsWithName] -         cty <- case lookupTy cn (tt_ctxt i) of-                    [t] -> return (delab i t)-                    _ -> ifail "Something went inexplicably wrong"-         cimp <- case lookupCtxt cn (idris_implicits i) of-                    [imps] -> return imps-         ppos <- case lookupCtxt tyn (idris_datatypes i) of-                    [ti] -> return $ param_pos ti-         let cty_imp = renameBs cimp cty-         let ptys = getProjs [] cty_imp-         let ptys_u = getProjs [] cty-         let recty = getRecTy cty_imp-         let recty_u = getRecTy cty+  where+    -- | Generates a type constructor.+    generateTyConType :: [(Name, FC, Plicity, PTerm)] -> PTerm+    generateTyConType ((n, nfc, p, t) : rest) = PPi p (nsroot n) nfc t (generateTyConType rest)+    generateTyConType [] = (PType fc) -         let paramNames = getPNames recty ppos+    -- | Generates a name for the data constructor if none was specified.+    generateDConName :: Maybe Name -> Idris Name+    generateDConName (Just n) = return $ expandNS csyn n+    generateDConName Nothing  = uniqueName (expandNS csyn $ sMN 0 ("Mk" ++ (show (nsroot tyn))))+      where+        uniqueName :: Name -> Idris Name+        uniqueName n = do i <- getIState+                          case lookupTyNameExact n (tt_ctxt i) of+                            Just _  -> uniqueName (nextName n)+                            Nothing -> return n -         -- rename indices when we generate the getter/setter types, so-         -- that they don't clash with the names of the projections-         -- we're generating-         let index_names_in = getRecNameMap "_in" ppos recty-         let recty_in = substMatches index_names_in recty+    -- | Generates the data constructor type.+    generateDConType :: [(Name, FC, Plicity, PTerm)] -> [(Name, FC, Plicity, PTerm, a)] -> PTerm+    generateDConType ((n, nfc, _, t) : ps) as                  = PPi impl (nsroot n) NoFC t (generateDConType ps as)+    generateDConType []               ((n, _, p, t, _) : as) = PPi p    (nsroot n) NoFC t (generateDConType [] as)+    generateDConType [] [] = target -         logLvl 3 $ show (recty, recty_u, ppos, paramNames, ptys)-         -- Substitute indices with projection functions, and parameters with-         -- the updated parameter name-         let substs = map (\ (n, _) -> -                             if n `elem` paramNames-                                then (n, PRef fc (mkp n))-                                else (n, PApp fc (PRef fc n)-                                                [pexp (PRef fc rec)])) -                          ptys +    -- | The target for the constructor and projection functions. Also the source of the update functions.+    target :: PTerm+    target = PApp fc (PRef fc tyn) $ map (uncurry asPRefArg) [(p, n) | (n, _, p, _) <- params] -         -- Generate projection functions-         proj_decls <- mapM (mkProj recty_in substs cimp) (zip ptys [0..])-         logLvl 3 $ show proj_decls-         let nonImp = mapMaybe isNonImp (zip cimp ptys_u)-         let implBinds = getImplB id cty'+    paramsAndDoc :: [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))]+    paramsAndDoc = pad params paramDocs+      where+        pad :: [(Name, FC, Plicity, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))]+        pad ((n, fc, p, t) : rest) docs+          = let d = case lookup n docs of+                     Just d' -> d+                     Nothing -> emptyDocstring+            in (n, fc, p, t, d) : (pad rest docs)+        pad _ _ = [] -         -- Generate update functions-         update_decls <- mapM (mkUpdate recty_u index_names_in extraImpls-                                   (getFieldNames cty')-                                   implBinds (length nonImp)) (zip nonImp [0..])-         mapM_ (rec_elabDecl info EAll info) (concat proj_decls)-         logLvl 3 $ show update_decls-         mapM_ (tryElabDecl info) (update_decls)+    dconsArgDocs :: [(Name, Docstring (Either Err PTerm))]+    dconsArgDocs = paramDocs ++ (dcad fieldsWithName)+      where+        dcad :: [(Name, FC, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, Docstring (Either Err PTerm))]+        dcad ((n, _, _, _, (Just d)) : rest) = ((nsroot n), d) : (dcad rest)+        dcad (_ : rest) = dcad rest+        dcad [] = []++    fieldsWithName :: [(Name, FC, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))]+    fieldsWithName = fwn [] fields+      where+        fwn :: [Name] -> [(Maybe (Name, FC), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, FC, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))]+        fwn ns ((n, p, t, d) : rest)+          = let nn = case n of+                      Just n' -> n'+                      Nothing -> newName ns baseName+                withNS = expandNS rsyn (fst nn)+            in (withNS, snd nn, p, t, d) : (fwn (fst nn : ns) rest)+        fwn _ _ = []++        baseName = (sUN "__pi_arg", NoFC)++        newName :: [Name] -> (Name, FC) -> (Name, FC)+        newName ns (n, nfc)+          | n `elem` ns = newName ns (nextName n, nfc)+          | otherwise = (n, nfc)++    fieldsWithNameAndDoc :: [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))]+    fieldsWithNameAndDoc = fwnad fieldsWithName+      where+        fwnad :: [(Name, FC, Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))]+        fwnad ((n, nfc, p, t, d) : rest)+          = let doc = fromMaybe emptyDocstring d+            in (n, nfc, p, t, doc) : (fwnad rest)+        fwnad [] = []++elabRecordFunctions :: ElabInfo -> SyntaxInfo -> FC+                    -> Name -- ^ Record type name+                    -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Parameters+                    -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Fields+                    -> Name -- ^ Constructor Name+                    -> PTerm -- ^ Target type+                    -> Idris ()+elabRecordFunctions info rsyn fc tyn params fields dconName target+  = do logLvl 1 $ "Elaborating helper functions for record " ++ show tyn++       iLOG $ "Fields: " ++ show fieldNames+       iLOG $ "Params: " ++ show paramNames+       -- The elaborated constructor type for the data declaration+       i <- getIState+       ttConsTy <-+         case lookupTyExact dconName (tt_ctxt i) of+               Just as -> return as+               Nothing -> tclift $ tfail $ At fc (Elaborating "record " tyn (InternalMsg "It seems like the constructor for this record has disappeared. :( \n This is a bug. Please report."))++       -- The arguments to the constructor+       let constructorArgs = getArgTys ttConsTy+       iLOG $ "Cons args: " ++ show constructorArgs+       iLOG $ "Free fields: " ++ show (filter (not . isFieldOrParam') constructorArgs)+       -- If elaborating the constructor has resulted in some new implicit fields we make projection functions for them.+       let freeFieldsForElab = map (freeField i) (filter (not . isFieldOrParam') constructorArgs)+           +       -- The parameters for elaboration with their documentation+       -- Parameter functions are all prefixed with "param_".+       let paramsForElab = [((nsroot n), (paramName n), impl, t, d) | (n, _, _, t, d) <- params] -- zipParams i params paramDocs]++       -- The fields (written by the user) with their documentation.+       let userFieldsForElab = [((nsroot n), n, p, t, d) | (n, nfc, p, t, d) <- fields]++       -- All things we need to elaborate projection functions for, together with a number denoting their position in the constructor.           +       let projectors = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (freeFieldsForElab ++ paramsForElab ++ userFieldsForElab) [0..]]       +       -- Build and elaborate projection functions+       elabProj dconName projectors++       logLvl 1 $ "Dependencies: " ++ show fieldDependencies++       logLvl 1 $ "Depended on: " ++ show dependedOn++       -- All things we need to elaborate update functions for, together with a number denoting their position in the constructor.+       let updaters = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (paramsForElab ++ userFieldsForElab) [0..]]+       -- Build and elaborate update functions+       elabUp dconName updaters   where---     syn = syn_in { syn_namespace = show (nsroot tyn) : syn_namespace syn_in }+    -- | Creates a PArg from a plicity and a name where the term is a Placeholder.+    placeholderArg :: Plicity -> Name -> PArg+    placeholderArg p n = asArg p (nsroot n) Placeholder -    isNonImp (PExp _ _ _ _, a) = Just a-    isNonImp _ = Nothing+    -- | Root names of all fields in the current record declarations+    fieldNames :: [Name]+    fieldNames = [nsroot n | (n, _, _, _, _) <- fields] -    getPNames (PApp _ _ as) ppos = getpn as ppos+    paramNames :: [Name]+    paramNames = [nsroot n | (n, _, _, _, _) <- params]++    isFieldOrParam :: Name -> Bool+    isFieldOrParam n = n `elem` (fieldNames ++ paramNames)++    isFieldOrParam' :: (Name, a) -> Bool+    isFieldOrParam' = isFieldOrParam . fst++    isField :: Name -> Bool+    isField = flip elem fieldNames++    isField' :: (Name, a, b, c, d, f) -> Bool+    isField' (n, _, _, _, _, _) = isField n++    fieldTerms :: [PTerm]+    fieldTerms = [t | (_, _, _, t, _) <- fields]++    -- Delabs the TT to PTerm+    -- This is not good.+    -- However, for machine generated implicits, there seems to be no PTerm available.+    -- Is there a better way to do this without building the setters and getters as TT?+    freeField :: IState -> (Name, TT Name) -> (Name, Name, Plicity, PTerm, Docstring (Either Err PTerm))+    freeField i arg = let nameInCons = fst arg -- The name as it appears in the constructor+                          nameFree = expandNS rsyn (freeName $ fst arg) -- The name prefixed with "free_"+                          plicity = impl -- All free fields are implicit as they are machine generated+                          fieldType = delab i (snd arg) -- The type of the field+                          doc = emptyDocstring -- No docmentation for machine generated fields+                      in (nameInCons, nameFree, plicity, fieldType, doc) ++    freeName :: Name -> Name+    freeName (UN n) = sUN ("free_" ++ str n)+    freeName (MN i n) = sMN i ("free_" ++ str n)+    freeName (NS n s) = NS (freeName n) s+    freeName n = n++    -- | Zips together parameters with their documentation. If no documentation for a given field exists, an empty docstring is used.+    zipParams :: IState -> [(Name, Plicity, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [(Name, PTerm, Docstring (Either Err PTerm))]+    zipParams i ((n, _, t) : rest) ((_, d) : rest') = (n, t, d) : (zipParams i rest rest')+    zipParams i ((n, _, t) : rest) [] = (n, t, emptyDoc) : (zipParams i rest [])+      where emptyDoc = annotCode (tryFullExpr rsyn i) emptyDocstring+    zipParams _ [] [] = []++    paramName :: Name -> Name+    paramName (UN n) = sUN ("param_" ++ str n)+    paramName (MN i n) = sMN i ("param_" ++ str n)+    paramName (NS n s) = NS (paramName n) s+    paramName n = n++    -- | Elaborate the projection functions.+    elabProj :: Name -> [(Name, Name, Plicity, PTerm, Docstring (Either Err PTerm), Int)] -> Idris ()+    elabProj cn fs = let phArgs = map (uncurry placeholderArg) [(p, n) | (n, _, p, _, _, _) <- fs]+                         elab = \(n, n', p, t, doc, i) ->+                              -- Use projections in types+                           do let t' = projectInType [(m, m') | (m, m', _, _, _, _) <- fs+                                                              -- Parameters are already in scope, so just use them+                                                              , not (m `elem` paramNames)] t+                              elabProjection info n n' p t' doc rsyn fc target cn phArgs fieldNames i+                     in mapM_ elab fs++    -- | Elaborate the update functions.+    elabUp :: Name -> [(Name, Name, Plicity, PTerm, Docstring (Either Err PTerm), Int)] -> Idris ()+    elabUp cn fs = let args = map (uncurry asPRefArg) [(p, n) | (n, _, p, _, _, _) <- fs]+                       elab = \(n, n', p, t, doc, i) -> elabUpdate info n n' p t doc rsyn fc target cn args fieldNames i (optionalSetter n)+                   in mapM_ elab fs++    -- | Decides whether a setter should be generated for a field or not.+    optionalSetter :: Name -> Bool+    optionalSetter n = n `elem` dependedOn+        +    -- | A map from a field name to the other fields it depends on.+    fieldDependencies :: [(Name, [Name])]+    fieldDependencies = map (uncurry fieldDep) [(n, t) | (n, _, _, t, _) <- fields ++ params]       where-        getpn as [] = []-        getpn as (i:is) | length as > i,-                          PRef _ n <- getTm (as!!i) = n : getpn as is-                        | otherwise = getpn as is-    getPNames _ _ = []-   -    tryElabDecl info (fn, ty, val)-        = do i <- getIState-             idrisCatch (do rec_elabDecl info EAll info ty-                            rec_elabDecl info EAll info val)-                        (\v -> do iputStrLn $ show fc ++-                                      ":Warning - can't generate setter for " ++-                                      show fn ++ " (" ++ show ty ++ ")"---                                       ++ "\n" ++ pshow i v-                                  putIState i)+        fieldDep :: Name -> PTerm -> (Name, [Name])+        fieldDep n t = ((nsroot n), paramNames ++ fieldNames `intersect` allNamesIn t) -    getBoundImpls (PPi (Imp _ _ _ _) n ty sc) = (n, ty) : getBoundImpls sc-    getBoundImpls _ = []+    -- | A list of fields depending on another field.+    dependentFields :: [Name]+    dependentFields = filter depends fieldNames+      where+        depends :: Name -> Bool+        depends n = case lookup n fieldDependencies of+                      Just xs -> not $ null xs+                      Nothing -> False -    getImplB k (PPi (Imp l s _ _) n Placeholder sc)-        = getImplB k sc-    getImplB k (PPi (Imp l s p fa) n ty sc)-        = getImplB (\x -> k (PPi (Imp l s p fa) n ty x)) sc-    getImplB k (PPi _ n ty sc)-        = getImplB k sc-    getImplB k _ = k+    -- | A list of fields depended on by other fields.+    dependedOn :: [Name]+    dependedOn = concat ((catMaybes (map (\x -> lookup x fieldDependencies) fieldNames))) -    renameBs (PImp _ _ _ _ _ : ps) (PPi p n ty s)-        = PPi p (mkImp n) ty (renameBs ps (substMatch n (PRef fc (mkImp n)) s))-    renameBs (_:ps) (PPi p n ty s) = PPi p n ty (renameBs ps s)-    renameBs _ t = t+-- | Creates and elaborates a projection function.+elabProjection :: ElabInfo+               -> Name -- ^ Name of the argument in the constructor+               -> Name -- ^ Projection Name+               -> Plicity -- ^ Projection Plicity+               -> PTerm -- ^ Projection Type+               -> (Docstring (Either Err PTerm)) -- ^ Projection Documentation+               -> SyntaxInfo -- ^ Projection SyntaxInfo+               -> FC -> PTerm -- ^ Projection target type+               -> Name -- ^ Data constructor tame+               -> [PArg] -- ^ Placeholder Arguments to constructor+               -> [Name] -- ^ All Field Names+               -> Int -- ^ Argument Index+               -> Idris ()+elabProjection info cname pname plicity projTy pdoc psyn fc targetTy cn phArgs fnames index+  = do logLvl 1 $ "Generating Projection for " ++ show pname+       +       let ty = generateTy+       logLvl 1 $ "Type of " ++ show pname ++ ": " ++ show ty+       +       let lhs = generateLhs+       logLvl 1 $ "LHS of " ++ show pname ++ ": " ++ showTmImpls lhs+       let rhs = generateRhs+       logLvl 1 $ "RHS of " ++ show pname ++ ": " ++ showTmImpls rhs -    getProjs acc (PPi _ n ty s) = getProjs ((n, ty) : acc) s-    getProjs acc r = reverse acc+       rec_elabDecl info EAll info ty -    getFieldNames (PPi (Exp _ _ _) n _ s) = n : getFieldNames s -    getFieldNames (PPi _ _ _ s) = getFieldNames s-    getFieldNames _ = []+       let clause = PClause fc pname lhs [] rhs []+       rec_elabDecl info EAll info $ PClauses fc [] pname [clause]+  where+    -- | The type of the projection function.+    generateTy :: PDecl+    generateTy = PTy pdoc [] psyn fc [] pname NoFC $+                   PPi expl recName NoFC targetTy projTy -    getRecTy (PPi _ n ty s) = getRecTy s-    getRecTy t = t+    -- | The left hand side of the projection function.+    generateLhs :: PTerm+    generateLhs = let args = lhsArgs index phArgs+                  in PApp fc (PRef fc pname) [pexp (PApp fc (PRef fc cn) args)]+      where+        lhsArgs :: Int -> [PArg] -> [PArg]+        lhsArgs 0 (_ : rest) = (asArg plicity (nsroot cname) (PRef fc pname_in)) : rest+        lhsArgs i (x : rest) = x : (lhsArgs (i-1) rest)+        lhsArgs _ [] = [] -    -- make sure we pick a consistent name for parameters; any name will do-    -- otherwise-    getRecNameMap x ppos (PApp fc t args) -         = mapMaybe toMN (zip [0..] (map getTm args))+    -- | The "_in" name. Used for the lhs.+    pname_in :: Name+    pname_in = rootname -- in_name rootname++    rootname :: Name+    rootname = nsroot cname++    -- | The right hand side of the projection function.+    generateRhs :: PTerm+    generateRhs = PRef fc pname_in++-- | Creates and elaborates an update function.+-- If 'optional' is true, we will not fail if we can't elaborate the update function.+elabUpdate :: ElabInfo+           -> Name -- ^ Name of the argument in the constructor+           -> Name -- ^ Field Name+           -> Plicity -- ^ Field Plicity+           -> PTerm -- ^ Field Type+           -> (Docstring (Either Err PTerm)) -- ^ Field Documentation+           -> SyntaxInfo -- ^ Field SyntaxInfo+           -> FC -> PTerm -- ^ Projection Source Type+           -> Name -- ^ Data Constructor Name+           -> [PArg] -- ^ Arguments to constructor+           -> [Name] -- ^ All fields+           -> Int -- ^ Argument Index+           -> Bool -- ^ Optional+           -> Idris ()+elabUpdate info cname pname plicity pty pdoc psyn fc sty cn args fnames i optional+  = do logLvl 1 $ "Generating Update for " ++ show pname+       +       let ty = generateTy+       logLvl 1 $ "Type of " ++ show set_pname ++ ": " ++ show ty+       +       let lhs = generateLhs+       logLvl 1 $ "LHS of " ++ show set_pname ++ ": " ++ showTmImpls lhs+       +       let rhs = generateRhs+       logLvl 1 $ "RHS of " ++ show set_pname ++ ": " ++ showTmImpls rhs++       let clause = PClause fc set_pname lhs [] rhs []       ++       idrisCatch (do rec_elabDecl info EAll info ty+                      rec_elabDecl info EAll info $ PClauses fc [] set_pname [clause])+         (\err -> logLvl 1 $ "Could not generate update function for " ++ show pname)+                  {-if optional+                  then logLvl 1 $ "Could not generate update function for " ++ show pname+                  else tclift $ tfail $ At fc (Elaborating "record update function " pname err)) -}+  where+    -- | The type of the update function.+    generateTy :: PDecl+    generateTy = PTy pdoc [] psyn fc [] set_pname NoFC $+                   PPi expl (nsroot pname) NoFC pty $+                     PPi expl recName NoFC sty (substInput sty)+      where substInput = substMatches [(cname, PRef fc (nsroot pname))]++    -- | The "_set" name.+    set_pname :: Name+    set_pname = set_name pname++    set_name :: Name -> Name+    set_name (UN n) = sUN ("set_" ++ str n)+    set_name (MN i n) = sMN i ("set_" ++ str n)+    set_name (NS n s) = NS (set_name n) s+    set_name n = n++    -- | The left-hand side of the update function.+    generateLhs :: PTerm+    generateLhs = PApp fc (PRef fc set_pname) [pexp $ PRef fc pname_in, pexp constructorPattern]       where-        toMN (i, PRef fc n) -             | i `elem` ppos = Just (n, PRef fc (mkp n))-             | otherwise = Just (n, PRef fc (sMN 0 (show n ++ x)))-        toMN _ = Nothing-    getRecNameMap x _ _ = []+        constructorPattern :: PTerm+        constructorPattern = PApp fc (PRef fc cn) args -    rec = sMN 0 "rec"+    -- | The "_in" name.+    pname_in :: Name+    pname_in = in_name rootname -    -- only UNs propagate properly as parameters (bit of a hack then...)-    mkp (UN n) = sUN ("_p_" ++ str n)-    mkp (MN i n) = sMN i ("p_" ++ str n)-    mkp (NS n s) = NS (mkp n) s+    rootname :: Name+    rootname = nsroot pname -    mkImp (UN n) = sUN ("implicit_" ++ str n)-    mkImp (MN i n) = sMN i ("implicit_" ++ str n)-    mkImp (NS n s) = NS (mkImp n) s+    -- | The right-hand side of the update function.+    generateRhs :: PTerm+    generateRhs = PApp fc (PRef fc cn) (newArgs i args)+      where+        newArgs :: Int -> [PArg] -> [PArg]+        newArgs 0 (_ : rest) = (asArg plicity (nsroot cname) (PRef fc pname_in)) : rest+        newArgs i (x : rest) = x : (newArgs (i-1) rest)+        newArgs _ [] = [] -    mkType (UN n) = sUN ("set_" ++ str n)-    mkType (MN i n) = sMN i ("set_" ++ str n)-    mkType (NS n s) = NS (mkType n) s+-- | Post-fixes a name with "_in".+in_name :: Name -> Name+in_name (UN n) = sMN 0 (str n ++ "_in")+in_name (MN i n) = sMN i (str n ++ "_in")+in_name (NS n s) = NS (in_name n) s+in_name n = n -    mkProj recty substs cimp ((pn_in, pty), pos)-        = do let pn = expandNS syn pn_in -- projection name-             -- use pn_in in the indices, consistently, to avoid clash-             let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] pn-                            (PPi expl rec recty-                               (substMatches substs pty))-             let pls = repeat Placeholder-             let before = pos-             let after = length substs - (pos + 1)-             let args = take before pls ++ PRef fc (mkp pn_in) : take after pls-             let iargs = map implicitise (zip cimp args)-             let lhs = PApp fc (PRef fc pn)-                        [pexp (PApp fc (PRef fc cn) iargs)]-             let rhs = PRef fc (mkp pn_in)-             let pclause = PClause fc pn lhs [] rhs []-             return [pfnTy, PClauses fc [] pn [pclause]]+-- | Creates a PArg with a given plicity, name, and term.+asArg :: Plicity -> Name -> PTerm -> PArg+asArg (Imp os _ _ _) n t = PImp 0 False os n t+asArg (Exp os _ _) n t = PExp 0 os n t+asArg (Constraint os _) n t = PConstraint 0 os n t+asArg (TacImp os _ s) n t = PTacImplicit 0 os n s t -    implicitise (pa, t) = pa { getTm = t }+-- | Machine name "rec".+recName :: Name+recName = sMN 0 "rec" -    -- If the 'pty' we're updating includes anything in 'substs', we're-    -- updating the type as well, so use recty', otherwise just use-    -- recty-    mkUpdate recty inames extras fnames k num ((pn, pty), pos)-       = do let setname = expandNS syn $ mkType pn-            let valname = sMN 0 "updateval"-            let pn_out = sMN 0 (show pn ++ "_out")-            let pn_in = sMN 0 (show pn ++ "_in")-            let recty_in = substMatches [(pn, PRef fc pn_in)] recty-            let recty_out = substMatches [(pn, PRef fc pn_out)] recty-            let pt = substMatches inames $ -                       k (implBindUp extras inames (PPi expl pn_out pty-                           (PPi expl rec recty_in recty_out)))-            let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] setname pt---             let pls = map (\x -> PRef fc (sMN x ("field" ++ show x))) [0..num-1]-            let inames_imp = map (\ (x,_) -> (x, Placeholder)) inames-            let pls = map (\x -> substMatches inames_imp (PRef fc x)) fnames-            let lhsArgs = pls-            let rhsArgs = take pos pls ++ (PRef fc valname) :-                               drop (pos + 1) pls-            let before = pos-            let pclause = PClause fc setname (PApp fc (PRef fc setname)-                                              [pexp (PRef fc valname),-                                               pexp (PApp fc (PRef fc cn)-                                                        (map pexp lhsArgs))])-                                             []-                                             (PApp fc (PRef fc cn)-                                                      (map pexp rhsArgs)) []-            return (pn, pfnTy, PClauses fc [] setname [pclause])+recRef = PRef emptyFC recName -    implBindUp [] is t = t-    implBindUp ((n, ty):ns) is t -         = let n' = case lookup n is of-                         Just (PRef _ x) -> x-                         _ -> n in-               if n `elem` allNamesIn t -                  then PPi impl n' ty (implBindUp ns is t)-                  else implBindUp ns is t+projectInType :: [(Name, Name)] -> PTerm -> PTerm+projectInType xs = mapPT st+  where+    st :: PTerm -> PTerm+    st (PRef fc n)+      | Just pn <- lookup n xs = PApp fc (PRef fc pn) [pexp recRef]+    st t = t++-- | Creates an PArg from a plicity and a name where the term is a PRef.+asPRefArg :: Plicity -> Name -> PArg+asPRefArg p n = asArg p (nsroot n) $ PRef emptyFC (nsroot n)
+ src/Idris/Elab/Term.hs view
@@ -0,0 +1,2375 @@+{-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+module Idris.Elab.Term where++import Idris.AbsSyntax+import Idris.AbsSyntaxTree+import Idris.DSL+import Idris.Delaborate+import Idris.Error+import Idris.ProofSearch+import Idris.Output (pshow)++import Idris.Core.CaseTree (SC, SC'(STerm), findCalls, findUsedArgs)+import Idris.Core.Elaborate hiding (Tactic(..))+import Idris.Core.TT+import Idris.Core.Evaluate+import Idris.Core.Unify+import Idris.Core.ProofTerm (getProofTerm)+import Idris.Core.Typecheck (check, recheck, isType)+import Idris.Coverage (buildSCG, checkDeclTotality, genClauses, recoverableCoverage, validCoverageCase)+import Idris.ErrReverse (errReverse)+import Idris.ElabQuasiquote (extractUnquotes)+import Idris.Elab.Utils+import Idris.Reflection+import qualified Util.Pretty as U++import Control.Applicative ((<$>))+import Control.Monad+import Control.Monad.State.Strict+import Data.List+import qualified Data.Map as M+import Data.Maybe (mapMaybe, fromMaybe, catMaybes)+import qualified Data.Set as S+import qualified Data.Text as T++import Debug.Trace++data ElabMode = ETyDecl | ELHS | ERHS+  deriving Eq+++data ElabResult =+  ElabResult { resultTerm :: Term -- ^ The term resulting from elaboration+             , resultMetavars :: [(Name, (Int, Maybe Name, Type))]+               -- ^ Information about new metavariables+             , resultCaseDecls :: [PDecl]+               -- ^ Deferred declarations as the meaning of case blocks+             , resultContext :: Context+               -- ^ The potentially extended context from new definitions+             , resultTyDecls :: [RDeclInstructions]+               -- ^ Meta-info about the new type declarations+             , resultHighlighting :: [(FC, OutputAnnotation)]+             }+++-- Using the elaborator, convert a term in raw syntax to a fully+-- elaborated, typechecked term.+--+-- If building a pattern match, we convert undeclared variables from+-- holes to pattern bindings.++-- Also find deferred names in the term and their types++build :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->+         ElabD ElabResult+build ist info emode opts fn tm+    = do elab ist info emode opts fn tm+         let tmIn = tm+         let inf = case lookupCtxt fn (idris_tyinfodata ist) of+                        [TIPartial] -> True+                        _ -> False++         when (not pattern) $ solveAutos ist fn True++         hs <- get_holes+         ivs <- get_instances+         ptm <- get_term+         -- Resolve remaining type classes. Two passes - first to get the+         -- default Num instances, second to clean up the rest+         when (not pattern) $+              mapM_ (\n -> when (n `elem` hs) $+                             do focus n+                                g <- goal+                                try (resolveTC True False 10 g fn ist)+                                    (movelast n)) ivs+         ivs <- get_instances+         hs <- get_holes+         when (not pattern) $+              mapM_ (\n -> when (n `elem` hs) $+                             do focus n+                                g <- goal+                                ptm <- get_term+                                resolveTC True True 10 g fn ist) ivs+         tm <- get_term+         ctxt <- get_context+         probs <- get_probs+         u <- getUnifyLog+         hs <- get_holes++         when (not pattern) $+           traceWhen u ("Remaining holes:\n" ++ show hs ++ "\n" +++                        "Remaining problems:\n" ++ qshow probs) $+             do unify_all; matchProblems True; unifyProblems++         probs <- get_probs+         case probs of+            [] -> return ()+            ((_,_,_,_,e,_,_):es) -> traceWhen u ("Final problems:\n" ++ qshow probs ++ "\nin\n" ++ show tm) $+                                     if inf then return ()+                                            else lift (Error e)++         when tydecl (do mkPat+                         update_term liftPats+                         update_term orderPats)+         EState is _ impls highlights <- getAux+         tt <- get_term+         ctxt <- get_context+         let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []+         log <- getLog+         if log /= ""+            then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights)+            else return (ElabResult tm ds (map snd is) ctxt impls highlights)+  where pattern = emode == ELHS+        tydecl = emode == ETyDecl++        mkPat = do hs <- get_holes+                   tm <- get_term+                   case hs of+                      (h: hs) -> do patvar h; mkPat+                      [] -> return ()++-- Build a term autogenerated as a typeclass method definition+-- (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 -> ElabMode -> FnOpts -> Name -> PTerm ->+         ElabD ElabResult+buildTC ist info emode opts fn tm+    = do -- set name supply to begin after highest index in tm+         let ns = allNamesIn tm+         let tmIn = tm+         let inf = case lookupCtxt fn (idris_tyinfodata ist) of+                        [TIPartial] -> True+                        _ -> False+         initNextNameFrom ns+         elab ist info emode opts fn tm+         probs <- get_probs+         tm <- get_term+         case probs of+            [] -> return ()+            ((_,_,_,_,e,_,_):es) -> if inf then return ()+                                           else lift (Error e)+         dots <- get_dotterm+         -- 'dots' are the PHidden things which have not been solved by+         -- unification+         when (not (null dots)) $+            lift (Error (CantMatch (getInferTerm tm)))+         EState is _ impls highlights <- getAux+         tt <- get_term+         ctxt <- get_context+         let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []+         log <- getLog+         if (log /= "")+            then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights)+            else return (ElabResult tm ds (map snd is) ctxt impls highlights)+  where pattern = emode == ELHS++-- return whether arguments of the given constructor name can be +-- matched on. If they're polymorphic, no, unless the type has beed made+-- concrete by the time we get around to elaborating the argument.+getUnmatchable :: Context -> Name -> [Bool]+getUnmatchable ctxt n | isDConName n ctxt && n /= inferCon+   = case lookupTyExact n ctxt of+          Nothing -> []+          Just ty -> checkArgs [] [] ty+  where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool]+        checkArgs env ns (Bind n (Pi _ t _) sc) +            = let env' = case t of+                              TType _ -> n : env+                              _ -> env in+                  checkArgs env' (intersect env (refsIn t) : ns) +                            (instantiate (P Bound n t) sc)+        checkArgs env ns t+            = map (not . null) (reverse ns)++getUnmatchable ctxt n = []++data ElabCtxt = ElabCtxt { e_inarg :: Bool,+                           e_isfn :: Bool, -- ^ Function part of application+                           e_guarded :: Bool, +                           e_intype :: Bool,+                           e_qq :: Bool,+                           e_nomatching :: Bool -- ^ can't pattern match+                         }++initElabCtxt = ElabCtxt False False False False False False++goal_polymorphic :: ElabD Bool+goal_polymorphic =+   do ty <- goal+      case ty of+           P _ n _ -> do env <- get_env+                         case lookup n env of+                              Nothing -> return False+                              _ -> return True+           _ -> return False++-- | Returns the set of declarations we need to add to complete the+-- definition (most likely case blocks to elaborate) as well as+-- declarations resulting from user tactic scripts (%runElab)+elab :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->+        ElabD ()+elab ist info emode opts fn tm+    = do let loglvl = opt_logLevel (idris_options ist)+         when (loglvl > 5) $ unifyLog True+         compute -- expand type synonyms, etc+         let fc = maybe "(unknown)"+         elabE initElabCtxt (elabFC info) tm -- (in argument, guarded, in type, in qquote)+         est <- getAux+         sequence_ (get_delayed_elab est)+         end_unify+         ptm <- get_term+         when pattern -- convert remaining holes to pattern vars+              (do update_term orderPats+                  unify_all+                  matchProblems False -- only the ones we matched earlier+                  unifyProblems+                  mkPat)+  where+    pattern = emode == ELHS+    bindfree = emode == ETyDecl || emode == ELHS++    get_delayed_elab est =+        let ds = delayed_elab est in+            map snd $ sortBy (\(p1, _) (p2, _) -> compare p1 p2) ds++    tcgen = Dictionary `elem` opts+    reflection = Reflection `elem` opts++    isph arg = case getTm arg of+        Placeholder -> (True, priority arg)+        tm -> (False, priority arg)++    toElab ina arg = case getTm arg of+        Placeholder -> Nothing+        v -> Just (priority arg, elabE ina (elabFC info) v)++    toElab' ina arg = case getTm arg of+        Placeholder -> Nothing+        v -> Just (elabE ina (elabFC info) v)++    mkPat = do hs <- get_holes+               tm <- get_term+               case hs of+                  (h: hs) -> do patvar h; mkPat+                  [] -> return ()++    -- | elabE elaborates an expression, possibly wrapping implicit coercions+    -- and forces/delays.  If you make a recursive call in elab', it is+    -- normally correct to call elabE - the ones that don't are desugarings+    -- typically+    elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()+    elabE ina fc' t = +     do solved <- get_recents+        as <- get_autos+        hs <- get_holes+        -- If any of the autos use variables which have recently been solved,+        -- have another go at solving them now.+        mapM_ (\(a, ns) -> if any (\n -> n `elem` solved) ns && head hs /= a+                              then solveAuto ist fn False a+                              else return ()) as+     +        itm <- if not pattern then insertImpLam ina t else return t+        ct <- insertCoerce ina itm+        t' <- insertLazy ct+        g <- goal+        tm <- get_term+        ps <- get_probs+        hs <- get_holes++        --trace ("Elaborating " ++ show t' ++ " in " ++ show g+        --         ++ "\n" ++ show tm+        --         ++ "\nholes " ++ show hs+        --         ++ "\nproblems " ++ show ps+        --         ++ "\n-----------\n") $+        --trace ("ELAB " ++ show t') $+        let fc = fileFC "Force"+        env <- get_env+        handleError (forceErr t' env)+            (elab' ina fc' t')+            (elab' ina fc' (PApp fc (PRef fc (sUN "Force"))+                             [pimp (sUN "t") Placeholder True,+                              pimp (sUN "a") Placeholder True,+                              pexp ct]))++    forceErr orig env (CantUnify _ (t,_) (t',_) _ _ _)+       | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),+            ht == txt "Lazy'" = notDelay orig+    forceErr orig env (CantUnify _ (t,_) (t',_) _ _ _)+       | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t'),+            ht == txt "Lazy'" = notDelay orig+    forceErr orig env (InfiniteUnify _ t _)+       | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),+            ht == txt "Lazy'" = notDelay orig+    forceErr orig env (Elaborating _ _ t) = forceErr orig env t+    forceErr orig env (ElaboratingArg _ _ _ t) = forceErr orig env t+    forceErr orig env (At _ t) = forceErr orig env t+    forceErr orig env t = False++    notDelay t@(PApp _ (PRef _ (UN l)) _) | l == txt "Delay" = False+    notDelay _ = True++    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 VoidType = True+    constType _ = False++    -- "guarded" means immediately under a constructor, to help find patvars++    elab' :: ElabCtxt  -- ^ (in an argument, guarded, in a type, in a quasiquote)+          -> Maybe FC -- ^ The closest FC in the syntax tree, if applicable+          -> PTerm -- ^ The term to elaborate+          -> ElabD ()+    elab' ina fc (PNoImplicits t) = elab' ina fc t -- skip elabE step+    elab' ina fc (PType fc')       =+      do apply RType []+         solve+         highlightSource fc' (AnnType "Type" "The type of types")+    elab' ina fc (PUniverse u)   = do apply (RUType u) []; solve+--  elab' (_,_,inty) (PConstant c)+--     | constType c && pattern && not reflection && not inty+--       = lift $ tfail (Msg "Typecase is not allowed")+    elab' ina fc tm@(PConstant fc' c) +         | pattern && not reflection && not (e_qq ina) && not (e_intype ina)+           && isTypeConst c+              = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)+         | pattern && not reflection && not (e_qq ina) && e_nomatching ina+              = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)+         | otherwise = do apply (RConstant c) []+                          solve+                          highlightSource fc' (AnnConst c)+    elab' ina fc (PQuote r)     = do fill r; solve+    elab' ina _ (PTrue fc _)   =+       do hnf_compute+          g <- goal+          case g of+            TType _ -> elab' ina (Just fc) (PRef fc unitTy)+            UType _ -> elab' ina (Just fc) (PRef fc unitTy)+            _ -> elab' ina (Just fc) (PRef fc unitCon)+    elab' ina fc (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes+       = do g <- goal; resolveTC False False 10 g fn ist+    elab' ina fc (PResolveTC fc')+        = do c <- getNameFrom (sMN 0 "class")+             instanceArg c+    -- Elaborate the equality type first homogeneously, then+    -- heterogeneously as a fallback+    elab' ina _ (PApp fc (PRef _ n) args)+       | n == eqTy, [Placeholder, Placeholder, l, r] <- map getTm args+       = try (do tyn <- getNameFrom (sMN 0 "aqty")+                 claim tyn RType+                 movelast tyn+                 elab' ina (Just fc) (PApp fc (PRef fc eqTy)+                              [pimp (sUN "A") (PRef NoFC tyn) True,+                               pimp (sUN "B") (PRef NoFC tyn) False,+                               pexp l, pexp r]))+             (do atyn <- getNameFrom (sMN 0 "aqty")+                 btyn <- getNameFrom (sMN 0 "bqty")+                 claim atyn RType+                 movelast atyn+                 claim btyn RType+                 movelast btyn+                 elab' ina (Just fc) (PApp fc (PRef fc eqTy)+                   [pimp (sUN "A") (PRef NoFC atyn) True,+                    pimp (sUN "B") (PRef NoFC btyn) False,+                    pexp l, pexp r]))++    elab' ina _ (PPair fc _ l r)+        = do hnf_compute+             g <- goal+             let (tc, _) = unApply g+             case g of+                TType _ -> elab' ina (Just fc) (PApp fc (PRef fc pairTy)+                                                      [pexp l,pexp r])+                UType _ -> elab' ina (Just fc) (PApp fc (PRef fc upairTy)+                                                      [pexp l,pexp r])+                _ -> case tc of+                        P _ n _ | n == upairTy +                          -> elab' ina (Just fc) (PApp fc (PRef fc upairCon)+                                                [pimp (sUN "A") Placeholder False,+                                                 pimp (sUN "B") Placeholder False,+                                                 pexp l, pexp r])+                        _ -> elab' ina (Just fc) (PApp fc (PRef fc pairCon)+                                                [pimp (sUN "A") Placeholder False,+                                                 pimp (sUN "B") Placeholder False,+                                                 pexp l, pexp r])+--                         _ -> try' (elab' ina (Just fc) (PApp fc (PRef fc pairCon)+--                                                 [pimp (sUN "A") Placeholder False,+--                                                  pimp (sUN "B") Placeholder False,+--                                                  pexp l, pexp r]))+--                                   (elab' ina (Just fc) (PApp fc (PRef fc upairCon)+--                                                 [pimp (sUN "A") Placeholder False,+--                                                  pimp (sUN "B") Placeholder False,+--                                                  pexp l, pexp r]))+--                                   True++    elab' ina _ (PDPair fc p l@(PRef _ n) t r)+            = case t of+                Placeholder ->+                   do hnf_compute+                      g <- goal+                      case g of+                         TType _ -> asType+                         _ -> asValue+                _ -> asType+         where asType = elab' ina (Just fc) (PApp fc (PRef fc sigmaTy)+                                        [pexp t,++                                         -- TODO: save the FC from the dependent pair+                                         -- syntax and put it on this lambda for interactive+                                         -- semantic highlighting support. NoFC for now.+                                         pexp (PLam fc n NoFC Placeholder r)])+               asValue = elab' ina (Just fc) (PApp fc (PRef fc sigmaCon)+                                         [pimp (sMN 0 "a") t False,+                                          pimp (sMN 0 "P") Placeholder True,+                                          pexp l, pexp r])+    elab' ina _ (PDPair fc p l t r) = elab' ina (Just fc) (PApp fc (PRef fc sigmaCon)+                                              [pimp (sMN 0 "a") t False,+                                               pimp (sMN 0 "P") Placeholder True,+                                               pexp l, pexp r])+    elab' ina fc (PAlternative (ExactlyOne delayok) as)+        = do hnf_compute+             ty <- goal+             ctxt <- get_context+             let (tc, _) = unApply ty+             env <- get_env+             let as' = pruneByType (map fst env) tc ctxt as+--              trace (-- show tc ++ " " ++ show as ++ "\n ==> " ++ +--                     show (length as') ++ "\n" +++--                     showSep ", " (map showTmImpls as') ++ "\nEND") $+             (h : hs) <- get_holes+             case as' of+                  [x] -> elab' ina fc x+                  -- If there's options, try now, and if that fails, postpone+                  -- to later.+                  _ -> handleError isAmbiguous+                           (tryAll (zip (map (elab' ina fc) as') +                                        (map showHd as')))+                        (do movelast h+                            delayElab 5 $ do+                              focus h+                              tryAll (zip (map (elab' ina fc) as') +                                          (map showHd as')))+        where showHd (PApp _ (PRef _ n) _) = n+              showHd (PRef _ n) = n+              showHd (PApp _ h _) = showHd h+              showHd x = NErased -- We probably should do something better than this here++              isAmbiguous (CantResolveAlts _) = delayok+              isAmbiguous (Elaborating _ _ e) = isAmbiguous e+              isAmbiguous (ElaboratingArg _ _ _ e) = isAmbiguous e+              isAmbiguous (At _ e) = isAmbiguous e+              isAmbiguous _ = False++    elab' ina fc (PAlternative FirstSuccess as)+        = trySeq as+        where -- if none work, take the error from the first+              trySeq (x : xs) = let e1 = elab' ina fc x in+                                    try' e1 (trySeq' e1 xs) True+              trySeq [] = fail "Nothing to try in sequence"+              trySeq' deferr [] = proofFail deferr+              trySeq' deferr (x : xs)+                  = try' (do elab' ina fc x+                             solveAutos ist fn False) (trySeq' deferr xs) True+    elab' ina _ (PPatvar fc n) | bindfree+        = do patvar n+             update_term liftPats+             highlightSource fc (AnnBoundName n False)+--    elab' (_, _, inty) (PRef fc f)+--       | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty+--          = lift $ tfail (Msg "Typecase is not allowed")+    elab' ec _ tm@(PRef fc n)+      | pattern && not reflection && not (e_qq ec) && not (e_intype ec)+            && isTConName n (tt_ctxt ist)+              = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)+      | pattern && not reflection && not (e_qq ec) && e_nomatching ec+              = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)+      | (pattern || (bindfree && bindable n)) && not (inparamBlock n) && not (e_qq ec)+        = do let ina = e_inarg ec+                 guarded = e_guarded ec+                 inty = e_intype ec+             ctxt <- get_context++             let defined = case lookupTy n ctxt of+                               [] -> False+                               _ -> True+           -- this is to stop us resolve type classes recursively+             -- trace (show (n, guarded)) $+             if (tcname n && ina)+               then erun fc $+                      do patvar n+                         update_term liftPats+                         highlightSource fc (AnnBoundName n False)+               else if (defined && not guarded)+                       then do apply (Var n) []+                               annot <- findHighlight n+                               solve+                               highlightSource fc annot+                       else try (do apply (Var n) []+                                    annot <- findHighlight n+                                    solve+                                    highlightSource fc annot)+                                (do patvar n+                                    update_term liftPats+                                    highlightSource fc (AnnBoundName n False))+      where inparamBlock n = case lookupCtxtName n (inblock info) of+                                [] -> False+                                _ -> True+            bindable (NS _ _) = False+            bindable (UN xs) = True+            bindable n = implicitable n+    elab' ina _ f@(PInferRef fc n) = elab' ina (Just fc) (PApp NoFC f [])+    elab' ina fc' tm@(PRef fc n) +          | pattern && not reflection && not (e_qq ina) && not (e_intype ina)+            && isTConName n (tt_ctxt ist)+              = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)+          | pattern && not reflection && not (e_qq ina) && e_nomatching ina+              = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)+          | otherwise =+               do fty <- get_type (Var n) -- check for implicits+                  ctxt <- get_context+                  env <- get_env+                  let a' = insertScopedImps fc (normalise ctxt env fty) []+                  if null a'+                     then erun fc $+                            do apply (Var n) []+                               hl <- findHighlight n+                               solve+                               highlightSource fc hl+                     else elab' ina fc' (PApp fc tm [])+    elab' ina _ (PLam _ _ _ _ PImpossible) = lift . tfail . Msg $ "Only pattern-matching lambdas can be impossible"+    elab' ina _ (PLam fc n nfc 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 (ina { e_inarg = True } ) (Just fc) sc; solve+               highlightSource nfc (AnnBoundName n False)+    elab' ec _ (PLam fc n nfc 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+               introTy (Var tyn) (Just n)+               focus tyn+               +               elabE (ec { e_inarg = True, e_intype = True }) (Just fc) ty+               elabE (ec { e_inarg = True }) (Just fc) sc+               solve+               highlightSource nfc (AnnBoundName n False)+    elab' ina fc (PPi p n nfc Placeholder sc)+          = do attack; arg n (is_scoped p) (sMN 0 "ty")+               elabE (ina { e_inarg = True, e_intype = True }) fc sc+               solve+               highlightSource nfc (AnnBoundName n False)+    elab' ina fc (PPi p n nfc ty sc)+          = do attack; tyn <- getNameFrom (sMN 0 "ty")+               claim tyn RType+               n' <- case n of+                        MN _ _ -> unique_hole n+                        _ -> return n+               forall n' (is_scoped p) (Var tyn)+               focus tyn+               let ec' = ina { e_inarg = True, e_intype = True }+               elabE ec' fc ty+               elabE ec' fc sc+               solve+               highlightSource nfc (AnnBoundName n False)+    elab' ina _ (PLet fc n nfc ty val sc)+          = do attack+               ivs <- get_instances+               tyn <- getNameFrom (sMN 0 "letty")+               claim tyn RType+               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+                           explicit tyn+                           elabE (ina { e_inarg = True, e_intype = True }) +                                 (Just fc) ty+               focus valn+               elabE (ina { e_inarg = True, e_intype = True }) +                     (Just fc) val+               ivs' <- get_instances+               env <- get_env+               elabE (ina { e_inarg = True }) (Just fc) sc+               when (not pattern) $+                   mapM_ (\n -> do focus n+                                   g <- goal+                                   hs <- get_holes+                                   if all (\n -> n == tyn || not (n `elem` hs)) (freeNames g)+                                    then try (resolveTC True False 10 g fn ist)+                                             (movelast n)+                                    else movelast n)+                         (ivs' \\ ivs)+               -- 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+                                 other -> error ("Value not a let binding: " ++ show other))+               solve+               highlightSource nfc (AnnBoundName n False)+    elab' ina _ (PGoal fc r n sc) = do+         rty <- goal+         attack+         tyn <- getNameFrom (sMN 0 "letty")+         claim tyn RType+         valn <- getNameFrom (sMN 0 "letval")+         claim valn (Var tyn)+         letbind n (Var tyn) (Var valn)+         focus valn+         elabE (ina { e_inarg = True, e_intype = True }) (Just fc) (PApp fc r [pexp (delab ist rty)])+         env <- get_env+         computeLet n+         elabE (ina { e_inarg = True }) (Just fc) sc+         solve+--          elab' ina fc (PLet n Placeholder+--              (PApp fc r [pexp (delab ist rty)]) sc)+    elab' ina _ tm@(PApp fc (PInferRef _ f) args) = do+         rty <- goal+         ds <- get_deferred+         ctxt <- get_context+         -- make a function type a -> b -> c -> ... -> rty for the+         -- new function name+         env <- get_env+         argTys <- claimArgTys env args+         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+         attack; deferType (mkN f) fty (map fst argTys); solve+         -- elaborate the arguments, to unify their types. They all have to+         -- be explicit.+         mapM_ elabIArg (zip argTys args)+       where claimArgTys env [] = return []+             claimArgTys env (arg : xs) | Just n <- localVar env (getTm arg)+                                  = do nty <- get_type (Var n)+                                       ans <- claimArgTys env xs+                                       return ((n, (False, forget nty)) : ans)+             claimArgTys env (_ : xs)+                                  = do an <- getNameFrom (sMN 0 "inf_argTy")+                                       aval <- getNameFrom (sMN 0 "inf_arg")+                                       claim an RType+                                       claim aval (Var an)+                                       ans <- claimArgTys env xs+                                       return ((aval, (True, (Var an))) : ans)+             fnTy [] ret  = forget ret+             fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi Nothing xt RType) (fnTy xs ret)++             localVar env (PRef _ x)+                           = case lookup x env of+                                  Just _ -> Just x+                                  _ -> Nothing+             localVar env _ = Nothing++             elabIArg ((n, (True, ty)), def) =+               do focus n; elabE ina (Just fc) (getTm def)+             elabIArg _ = return () -- already done, just a name++             mkN n@(NS _ _) = n+             mkN n@(SN _) = n+             mkN n = case namespace info of+                        Just xs@(_:_) -> sNS n xs+                        _ -> n++    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+    -- if f is local, just do a simple_app+    -- FIXME: Anyone feel like refactoring this mess? - EB+    elab' ina topfc tm@(PApp fc (PRef ffc f) args_in)+      | pattern && not reflection && not (e_qq ina) && e_nomatching ina+              = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)+      | otherwise = implicitApp $+         do env <- get_env+            ty <- goal+            fty <- get_type (Var f)+            ctxt <- get_context+            annot <- findHighlight f+            let args = insertScopedImps fc (normalise ctxt env fty) args_in+            let unmatchableArgs = if pattern +                                     then getUnmatchable (tt_ctxt ist) f+                                     else []+--             trace ("BEFORE " ++ show f ++ ": " ++ show ty) $ +            when (pattern && not reflection && not (e_qq ina) && not (e_intype ina)+                          && isTConName f (tt_ctxt ist)) $+              lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)+            if (f `elem` map fst env && length args == 1 && length args_in == 1)+               then -- simple app, as below+                    do simple_app False+                                  (elabE (ina { e_isfn = True }) (Just fc) (PRef ffc f))+                                  (elabE (ina { e_inarg = True }) (Just fc) (getTm (head args)))+                                  (show tm)+                       solve+                       highlightSource ffc annot+                       return []+               else+                 do ivs <- get_instances+                    ps <- get_probs+                    -- HACK: we shouldn't resolve type classes if we're defining an instance+                    -- function or default definition.+                    let isinf = f == inferCon || tcname f+                    -- if f is a type class, we need to know its arguments so that+                    -- we can unify with them+                    case lookupCtxt f (idris_classes ist) of+                        [] -> return ()+                        _ -> do mapM_ setInjective (map getTm args)+                                -- maybe more things are solvable now+                                unifyProblems+                    let guarded = isConName f ctxt+--                    trace ("args is " ++ show args) $ return ()+                    ns <- apply (Var f) (map isph args)+--                    trace ("ns is " ++ show ns) $ return ()+                    -- mark any type class arguments as injective+                    mapM_ checkIfInjective (map snd ns)+                    unifyProblems -- try again with the new information,+                                  -- to help with disambiguation+                    ulog <- getUnifyLog++                    annot <- findHighlight f+                    highlightSource ffc annot++                    elabArgs ist (ina { e_inarg = e_inarg ina || not isinf }) +                           [] fc False f+                             (zip ns (unmatchableArgs ++ repeat False))+                             (f == sUN "Force")+                             (map (\x -> getTm x) args) -- TODO: remove this False arg+                    imp <- if (e_isfn ina) then+                              do guess <- get_guess+                                 gty <- get_type (forget guess)+                                 env <- get_env+                                 let ty_n = normalise ctxt env gty+                                 return $ getReqImps ty_n+                              else return []+                    -- Now we find out how many implicits we needed at the+                    -- end of the application by looking at the goal again+                    -- - Have another go, but this time add the+                    -- implicits (can't think of a better way than this...)+                    case imp of+                         rs@(_:_) | not pattern -> return rs -- quit, try again+                         _ -> do solve+                                 hs <- get_holes+                                 ivs' <- get_instances+                                 -- Attempt to resolve any type classes which have 'complete' types,+                                 -- i.e. no holes in them+                                 when (not pattern || (e_inarg ina && not tcgen && +                                                      not (e_guarded ina))) $+                                    mapM_ (\n -> do focus n+                                                    g <- goal+                                                    env <- get_env+                                                    hs <- get_holes+                                                    if all (\n -> not (n `elem` hs)) (freeNames g)+                                                     then try (resolveTC False False 10 g fn ist)+                                                              (movelast n)+                                                     else movelast n)+                                          (ivs' \\ ivs)+                                 return []+      where +            -- Run the elaborator, which returns how many implicit+            -- args were needed, then run it again with those args. We need+            -- this because we have to elaborate the whole application to+            -- find out whether any computations have caused more implicits+            -- to be needed.+            implicitApp :: ElabD [ImplicitInfo] -> ElabD ()+            implicitApp elab +              | pattern = do elab; return ()+              | otherwise+                = do s <- get+                     imps <- elab+                     case imps of+                          [] -> return ()+                          es -> do put s+                                   elab' ina topfc (PAppImpl tm es)+    +            getReqImps (Bind x (Pi (Just i) ty _) sc)+                 = i : getReqImps sc+            getReqImps _ = []++            checkIfInjective n = do+                env <- get_env+                case lookup n env of+                     Nothing -> return ()+                     Just b ->+                       case unApply (binderTy b) of+                            (P _ c _, args) ->+                                case lookupCtxtExact c (idris_classes ist) of+                                   Nothing -> return ()+                                   Just ci -> -- type class, set as injective+                                        do mapM_ setinjArg (getDets 0 (class_determiners ci) args)+                                        -- maybe we can solve more things now...+                                           ulog <- getUnifyLog+                                           probs <- get_probs+                                           traceWhen ulog ("Injective now " ++ show args ++ "\n" ++ qshow probs) $+                                             unifyProblems+                                           probs <- get_probs+                                           traceWhen ulog (qshow probs) $ return ()+                            _ -> return ()++            setinjArg (P _ n _) = setinj n+            setinjArg _ = return ()++            getDets i ds [] = []+            getDets i ds (a : as) | i `elem` ds = a : getDets (i + 1) ds as+                                  | otherwise = getDets (i + 1) ds as++            tacTm (PTactics _) = True+            tacTm (PProof _) = True+            tacTm _ = False++            setInjective (PRef _ n) = setinj n+            setInjective (PApp _ (PRef _ n) _) = setinj n+            setInjective _ = return ()++    elab' ina _ tm@(PApp fc f [arg]) =+            erun fc $+             do simple_app (not $ headRef f)+                           (elabE (ina { e_isfn = True }) (Just fc) f)+                           (elabE (ina { e_inarg = True }) (Just fc) (getTm arg))+                                (show tm)+                solve+        where headRef (PRef _ _) = True+              headRef (PApp _ f _) = headRef f+              headRef (PAlternative _ as) = all headRef as+              headRef _ = False++    elab' ina fc (PAppImpl f es) = do appImpl (reverse es) -- not that we look... +                                      solve+        where appImpl [] = elab' (ina { e_isfn = False }) fc f -- e_isfn not set, so no recursive expansion of implicits+              appImpl (e : es) = simple_app False+                                            (appImpl es)+                                            (elab' ina fc Placeholder)+                                            (show f)+    elab' ina fc Placeholder+        = do (h : hs) <- get_holes+             movelast h+    elab' ina fc (PMetavar nfc n) =+          do ptm <- get_term+             -- When building the metavar application, leave out the unique+             -- names which have been used elsewhere in the term, since we+             -- won't be able to use them in the resulting application.+             let unique_used = getUniqueUsed (tt_ctxt ist) ptm+             let n' = mkN n+             attack+             defer unique_used n'+             solve+             highlightSource nfc (AnnName n' (Just MetavarOutput) Nothing Nothing)+        where mkN n@(NS _ _) = n+              mkN n = case namespace info of+                        Just xs@(_:_) -> sNS n xs+                        _ -> n+    elab' ina fc (PProof ts) = do compute; mapM_ (runTac True ist (elabFC info) fn) ts+    elab' ina fc (PTactics ts)+        | not pattern = do mapM_ (runTac False ist fc fn) ts+        | otherwise = elab' ina fc Placeholder+    elab' ina fc (PElabError e) = lift $ tfail e+    elab' ina _ (PRewrite fc r sc newg)+        = do attack+             tyn <- getNameFrom (sMN 0 "rty")+             claim tyn RType+             valn <- getNameFrom (sMN 0 "rval")+             claim valn (Var tyn)+             letn <- getNameFrom (sMN 0 "_rewrite_rule")+             letbind letn (Var tyn) (Var valn)+             focus valn+             elab' ina (Just fc) r+             compute+             g <- goal+             rewrite (Var letn)+             g' <- goal+             when (g == g') $ lift $ tfail (NoRewriting g)+             case newg of+                 Nothing -> elab' ina (Just fc) sc+                 Just t -> doEquiv t sc+             solve+        where doEquiv t sc =+                do attack+                   tyn <- getNameFrom (sMN 0 "ety")+                   claim tyn RType+                   valn <- getNameFrom (sMN 0 "eqval")+                   claim valn (Var tyn)+                   letn <- getNameFrom (sMN 0 "equiv_val")+                   letbind letn (Var tyn) (Var valn)+                   focus tyn+                   elab' ina (Just fc) t+                   focus valn+                   elab' ina (Just fc) sc+                   elab' ina (Just fc) (PRef fc letn)+                   solve+    elab' ina _ c@(PCase fc scr opts)+        = do attack+             tyn <- getNameFrom (sMN 0 "scty")+             claim tyn RType+             valn <- getNameFrom (sMN 0 "scval")+             scvn <- getNameFrom (sMN 0 "scvar")+             claim valn (Var tyn)+             letbind scvn (Var tyn) (Var valn)+             focus valn+             elabE (ina { e_inarg = True }) (Just fc) scr+             -- Solve any remaining implicits - we need to solve as many+             -- as possible before making the 'case' type+             unifyProblems+             matchProblems True+             args <- get_env+             envU <- mapM (getKind args) args+             let namesUsedInRHS = nub $ scvn : concatMap (\(_,rhs) -> allNamesIn rhs) opts++             -- Drop the unique arguments used in the term already+             -- and in the scrutinee (since it's+             -- not valid to use them again anyway) +             --+             -- Also drop unique arguments which don't appear explicitly+             -- in either case branch so they don't count as used+             -- unnecessarily (can only do this for unique things, since we+             -- assume they don't appear implicitly in types)+             ptm <- get_term+             let inOpts = (filter (/= scvn) (map fst args)) \\ (concatMap (\x -> allNamesIn (snd x)) opts)++             let argsDropped = filter (isUnique envU) +                                   (nub $ allNamesIn scr ++ inApp ptm +++                                    inOpts)++             let args' = filter (\(n, _) -> n `notElem` argsDropped) args++             cname <- unique_hole' True (mkCaseName fn)+             let cname' = mkN cname+--              elab' ina fc (PMetavar cname')+             attack; defer argsDropped cname'; solve++             -- if the scrutinee is one of the 'args' in env, we should+             -- inspect it directly, rather than adding it as a new argument+             let newdef = PClauses fc [] cname'+                             (caseBlock fc cname'+                                (map (isScr scr) (reverse args')) opts)+             -- elaborate case+             updateAux (\e -> e { case_decls = (cname', newdef) : case_decls e } )+             -- if we haven't got the type yet, hopefully we'll get it later!+             movelast tyn+             solve+        where mkCaseName (NS n ns) = NS (mkCaseName n) ns+              mkCaseName n = SN (CaseN n)+--               mkCaseName (UN x) = UN (x ++ "_case")+--               mkCaseName (MN i x) = MN i (x ++ "_case")+              mkN n@(NS _ _) = n+              mkN n = case namespace info of+                        Just xs@(_:_) -> sNS n xs+                        _ -> n++              inApp (P _ n _) = [n]+              inApp (App _ f a) = inApp f ++ inApp a+              inApp (Bind n (Let _ v) sc) = inApp v ++ inApp sc+              inApp (Bind n (Guess _ v) sc) = inApp v ++ inApp sc+              inApp (Bind n b sc) = inApp sc+              inApp _ = []++              isUnique envk n = case lookup n envk of+                                     Just u -> u+                                     _ -> False++              getKind env (n, _)+                  = case lookup n env of+                         Nothing -> return (n, False) -- can't happen, actually...+                         Just b ->+                            do ty <- get_type (forget (binderTy b))+                               case ty of+                                    UType UniqueType -> return (n, True)+                                    UType AllTypes -> return (n, True)+                                    _ -> return (n, False)++              tcName tm | (P _ n _, _) <- unApply tm+                  = case lookupCtxt n (idris_classes ist) of+                         [_] -> True+                         _ -> False+              tcName _ = False++              usedIn ns (n, b)+                 = n `elem` ns+                     || any (\x -> x `elem` ns) (allTTNames (binderTy b))++    elab' ina fc (PUnifyLog t) = do unifyLog True+                                    elab' ina fc t+                                    unifyLog False+    elab' ina fc (PQuasiquote t goalt)+        = do -- First extract the unquoted subterms, replacing them with fresh+             -- names in the quasiquoted term. Claim their reflections to be+             -- an inferred type (to support polytypic quasiquotes).+             finalTy <- goal+             (t, unq) <- extractUnquotes 0 t+             let unquoteNames = map fst unq+             mapM_ (\uqn -> claim uqn (forget finalTy)) unquoteNames++             -- Save the old state - we need a fresh proof state to avoid+             -- capturing lexically available variables in the quoted term.+             ctxt <- get_context+             datatypes <- get_datatypes+             saveState+             updatePS (const .+                       newProof (sMN 0 "q") ctxt datatypes $+                       P Ref (reflm "TT") Erased)++             -- Re-add the unquotes, letting Idris infer the (fictional)+             -- types. Here, they represent the real type rather than the type+             -- of their reflection.+             mapM_ (\n -> do ty <- getNameFrom (sMN 0 "unqTy")+                             claim ty RType+                             movelast ty+                             claim n (Var ty)+                             movelast n)+                   unquoteNames++             -- Determine whether there's an explicit goal type, and act accordingly+             -- Establish holes for the type and value of the term to be+             -- quasiquoted+             qTy <- getNameFrom (sMN 0 "qquoteTy")+             claim qTy RType+             movelast qTy+             qTm <- getNameFrom (sMN 0 "qquoteTm")+             claim qTm (Var qTy)++             -- Let-bind the result of elaborating the contained term, so that+             -- the hole doesn't disappear+             nTm <- getNameFrom (sMN 0 "quotedTerm")+             letbind nTm (Var qTy) (Var qTm)++             -- Fill out the goal type, if relevant+             case goalt of+               Nothing  -> return ()+               Just gTy -> do focus qTy+                              elabE (ina { e_qq = True }) fc gTy++             -- Elaborate the quasiquoted term into the hole+             focus qTm+             elabE (ina { e_qq = True }) fc t+             end_unify++             -- We now have an elaborated term. Reflect it and solve the+             -- original goal in the original proof state, preserving highlighting+             env <- get_env+             EState _ _ _ hs <- getAux+             loadState+             updateAux (\aux -> aux { highlighting = hs })++             let quoted = fmap (explicitNames . binderVal) $ lookup nTm env+                 isRaw = case unApply (normaliseAll ctxt env finalTy) of+                           (P _ n _, []) | n == reflm "Raw" -> True+                           _ -> False+             case quoted of+               Just q -> do ctxt <- get_context+                            (q', _, _) <- lift $ recheck ctxt [(uq, Lam Erased) | uq <- unquoteNames] (forget q) q+                            if pattern+                              then if isRaw+                                      then reflectRawQuotePattern unquoteNames (forget q')+                                      else reflectTTQuotePattern unquoteNames q'+                              else do if isRaw+                                        then -- we forget q' instead of using q to ensure rechecking+                                             fill $ reflectRawQuote unquoteNames (forget q')+                                        else fill $ reflectTTQuote unquoteNames q'+                                      solve++               Nothing -> lift . tfail . Msg $ "Broken elaboration of quasiquote"++             -- Finally fill in the terms or patterns from the unquotes. This+             -- happens last so that their holes still exist while elaborating+             -- the main quotation.+             mapM_ elabUnquote unq+      where elabUnquote (n, tm)+                = do focus n+                     elabE (ina { e_qq = False }) fc tm+++    elab' ina fc (PUnquote t) = fail "Found unquote outside of quasiquote"+    elab' ina fc (PQuoteName n) =+      do ctxt <- get_context+         env <- get_env+         case lookup n env of+           Just _ -> do fill $ reflectName n ; solve+           Nothing ->+             case lookupNameDef n ctxt of+               [(n', _)] -> do fill $ reflectName n'+                               solve+               [] -> lift . tfail . NoSuchVariable $ n+               more -> lift . tfail . CantResolveAlts $ map fst more+    elab' ina fc (PAs _ n t) = lift . tfail . Msg $ "@-pattern not allowed here"+    elab' ina fc (PHidden t) +      | reflection = elab' ina fc t+      | otherwise+        = do (h : hs) <- get_holes+             -- Dotting a hole means that either the hole or any outer+             -- hole (a hole outside any occurrence of it) +             -- must be solvable by unification as well as being filled+             -- in directly.+             -- Delay dotted things to the end, then when we elaborate them+             -- we can check the result against what was inferred+             movelast h+             delayElab 10 $ do focus h+                               dotterm+                               elab' ina fc t+    elab' ina fc (PRunElab fc' tm) =+      do attack+         n <- getNameFrom (sMN 0 "tacticScript")+         n' <- getNameFrom (sMN 0 "tacticExpr")+         let scriptTy = RApp (Var (sNS (sUN "Elab")+                                  ["Elab", "Reflection", "Language"]))+                             (Var unitTy)+         claim n scriptTy+         movelast n+         letbind n' scriptTy (Var n)+         focus n+         elab' ina (Just fc') tm+         env <- get_env+         runTactical ist (maybe fc' id fc) env (P Bound n' Erased)+         solve+    elab' ina fc x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x++    -- delay elaboration of 't', with priority 'pri' until after everything+    -- else is done.+    -- The delayed things with lower numbered priority will be elaborated+    -- first. (In practice, this means delayed alternatives, then PHidden+    -- things.)+    delayElab pri t +       = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [(pri, t)] })++    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' = findScr env+              args = map mkarg (map getNmScr args') in+              map (mkClause args) opts++       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!+             findScr [] = error "The impossible happened - the scrutinee was not 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 (mkLHSarg l) args') in+                            PClause (getFC fc l) n lhs [] r []++             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+    getFC d (PRef fc _) = fc+    getFC d (PAlternative _ (x:_)) = getFC d x+    getFC d x = d++    insertLazy :: PTerm -> ElabD PTerm+    insertLazy t@(PApp _ (PRef _ (UN l)) _) | l == txt "Delay" = return t+    insertLazy t@(PApp _ (PRef _ (UN l)) _) | l == txt "Force" = return t+    insertLazy (PCoerced t) = return t+    insertLazy t =+        do ty <- goal+           env <- get_env+           let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)+           let tries = if pattern then [t, mkDelay env t] else [mkDelay env t, t]+           case tyh of+                P _ (UN l) _ | l == txt "Lazy'"+                    -> return (PAlternative FirstSuccess tries)+                _ -> return t+      where+        mkDelay env (PAlternative b xs) = PAlternative b (map (mkDelay env) xs)+        mkDelay env t+            = let fc = fileFC "Delay" in+                  addImplBound ist (map fst env) (PApp fc (PRef fc (sUN "Delay"))+                                                 [pexp t])+++    -- Don't put implicit coercions around applications which are marked+    -- as '%noImplicit', or around case blocks, otherwise we get exponential+    -- blowup especially where there are errors deep in large expressions.+    notImplicitable (PApp _ f _) = notImplicitable f+    -- TMP HACK no coercing on bind (make this configurable)+    notImplicitable (PRef _ n)+        | [opts] <- lookupCtxt n (idris_flags ist)+            = NoImplicit `elem` opts+    notImplicitable (PAlternative (ExactlyOne _) as) = any notImplicitable as+    -- case is tricky enough without implicit coercions! If they are needed,+    -- they can go in the branches separately.+    notImplicitable (PCase _ _ _) = True+    notImplicitable _ = False++    insertScopedImps fc (Bind n (Pi im@(Just i) _ _) sc) xs+      | tcinstance i+          = pimp n (PResolveTC fc) True : insertScopedImps fc sc xs+      | otherwise+          = pimp n Placeholder True : insertScopedImps fc sc xs+    insertScopedImps fc (Bind n (Pi _ _ _) sc) (x : xs)+        = x : insertScopedImps fc sc xs+    insertScopedImps _ _ xs = xs++    insertImpLam ina t =+        do ty <- goal+           env <- get_env+           let ty' = normalise (tt_ctxt ist) env ty+           addLam ty' t+      where+        -- just one level at a time+        addLam (Bind n (Pi (Just _) _ _) sc) t =+                 do impn <- unique_hole (sMN 0 "imp")+                    if e_isfn ina -- apply to an implicit immediately+                       then return (PApp emptyFC+                                         (PLam emptyFC impn NoFC Placeholder t)+                                         [pexp Placeholder])+                       else return (PLam emptyFC impn NoFC Placeholder t)+        addLam _ t = return t++    insertCoerce ina t@(PCase _ _ _) = return t+    insertCoerce ina t | notImplicitable t = return t+    insertCoerce ina t =+        do ty <- goal+           -- Check for possible coercions to get to the goal+           -- and add them as 'alternatives'+           env <- get_env+           let ty' = normalise (tt_ctxt ist) env ty+           let cs = getCoercionsTo ist ty'+           let t' = case (t, cs) of+                         (PCoerced tm, _) -> tm+                         (_, []) -> t+                         (_, cs) -> PAlternative FirstSuccess [t ,+                                       PAlternative (ExactlyOne False) +                                            (map (mkCoerce env t) cs)]+           return t'+       where+         mkCoerce env t n = let fc = maybe (fileFC "Coercion") id (highestFC t) in+                                addImplBound ist (map fst env)+                                  (PApp fc (PRef fc n) [pexp (PCoerced t)])++    -- | Elaborate the arguments to a function+    elabArgs :: IState -- ^ The current Idris state+             -> ElabCtxt -- ^ (in an argument, guarded, in a type, in a qquote)+             -> [Bool]+             -> FC -- ^ Source location+             -> Bool+             -> Name -- ^ Name of the function being applied+             -> [((Name, Name), Bool)] -- ^ (Argument Name, Hole Name, unmatchable)+             -> Bool -- ^ under a 'force'+             -> [PTerm] -- ^ argument+             -> ElabD ()+    elabArgs ist ina failed fc retry f [] force _ = return ()+    elabArgs ist ina failed fc r f (((argName, holeName), unm):ns) force (t : args)+        = do hs <- get_holes+             if holeName `elem` hs then+                do focus holeName+                   case t of+                      Placeholder -> do movelast holeName+                                        elabArgs ist ina failed fc r f ns force args+                      _ -> elabArg t+                else elabArgs ist ina failed fc r f ns force args+      where elabArg t =+              do -- solveAutos ist fn False+                 now_elaborating fc f argName+                 wrapErr f argName $ do+                   hs <- get_holes+                   tm <- get_term+                   -- No coercing under an explicit Force (or it can Force/Delay+                   -- recursively!)+                   let elab = if force then elab' else elabE+                   failed' <- -- trace (show (n, t, hs, tm)) $+                              -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $+                              do focus holeName;+                                 g <- goal+                                 -- Can't pattern match on polymorphic goals+                                 poly <- goal_polymorphic+                                 ulog <- getUnifyLog+                                 traceWhen ulog ("Elaborating argument " ++ show (argName, holeName, g)) $+                                  elab (ina { e_nomatching = unm && poly }) (Just fc) t+                                 return failed+                   done_elaborating_arg f argName+                   elabArgs ist ina failed fc r f ns force args+            wrapErr f argName action =+              do elabState <- get+                 while <- elaborating_app+                 let while' = map (\(x, y, z)-> (y, z)) while+                 (result, newState) <- case runStateT action elabState of+                                         OK (res, newState) -> return (res, newState)+                                         Error e -> do done_elaborating_arg f argName+                                                       lift (tfail (elaboratingArgErr while' e))+                 put newState+                 return result+    elabArgs _ _ _ _ _ _ (((arg, hole), _) : _) _ [] =+      fail $ "Can't elaborate these args: " ++ show arg ++ " " ++ show hole++-- For every alternative, look at the function at the head. Automatically resolve+-- any nested alternatives where that function is also at the head++pruneAlt :: [PTerm] -> [PTerm]+pruneAlt xs = map prune xs+  where+    prune (PApp fc1 (PRef fc2 f) as)+        = PApp fc1 (PRef fc2 f) (fmap (fmap (choose f)) as)+    prune t = t++    choose f (PAlternative a as)+        = let as' = fmap (choose f) as+              fs = filter (headIs f) as' in+              case fs of+                 [a] -> a+                 _ -> PAlternative a as'++    choose f (PApp fc f' as) = PApp fc (choose f f') (fmap (fmap (choose f)) as)+    choose f t = t++    headIs f (PApp _ (PRef _ f') _) = f == f'+    headIs f (PApp _ f' _) = headIs f f'+    headIs f _ = True -- keep if it's not an application++-- Rule out alternatives that don't return the same type as the head of the goal+-- (If there are none left as a result, do nothing)+pruneByType :: [Name] -> Term -> -- head of the goal+               Context -> [PTerm] -> [PTerm]+-- if an alternative has a locally bound name at the head, take it+pruneByType env t c as+   | Just a <- locallyBound as = [a]+  where+    locallyBound [] = Nothing+    locallyBound (t:ts)+       | Just n <- getName t,+         n `elem` env = Just t+       | otherwise = locallyBound ts+    getName (PRef _ n) = Just n+    getName (PApp _ f _) = getName f+    getName (PHidden t) = getName t+    getName _ = Nothing++pruneByType env (P _ n _) ctxt as+-- if the goal type is polymorphic, keep e+   | [] <- lookupTy n ctxt = as+   | otherwise+       = let asV = filter (headIs True n) as+             as' = filter (headIs False n) as in+             case as' of+               [] -> case asV of+                        [] -> as+                        _ -> asV+               _ -> as'+  where+    headIs var f (PApp _ (PRef _ f') _) = typeHead var f f'+    headIs var f (PApp _ f' _) = headIs var f f'+    headIs var f (PPi _ _ _ _ sc) = headIs var f sc+    headIs var f (PHidden t) = headIs var f t+    headIs _ _ _ = True -- keep if it's not an application++    typeHead var f f'+        = -- trace ("Trying " ++ show f' ++ " for " ++ show n) $+          case lookupTy f' ctxt of+               [ty] -> case unApply (getRetTy ty) of+                            (P _ ctyn _, _) | isConName ctyn ctxt -> ctyn == f+                            _ -> let ty' = normalise ctxt [] ty in+                                     case unApply (getRetTy ty') of+                                          (P _ ftyn _, _) -> ftyn == f+                                          (V _, _) -> var -- keep, variable+                                          _ -> False+               _ -> False++pruneByType _ t _ as = as++-- | Use the local elab context to work out the highlighting for a name+findHighlight :: Name -> ElabD OutputAnnotation+findHighlight n = do ctxt <- get_context+                     env <- get_env+                     case lookup n env of+                       Just _ -> return $ AnnBoundName n False+                       Nothing -> case lookupTyExact n ctxt of+                                    Just _ -> return $ AnnName n Nothing Nothing Nothing+                                    Nothing -> lift . tfail . InternalMsg $+                                                 "Can't find name" ++ show n++-- | Find the names of instances that have been designeated for+-- searching (i.e. non-named instances or instances from Elab scripts)+findInstances :: IState -> Term -> [Name]+findInstances ist t+    | (P _ n _, _) <- unApply (getRetTy t)+        = case lookupCtxt n (idris_classes ist) of+            [CI _ _ _ _ _ ins _] ->+              [n | (n, True) <- ins, accessible n]+            _ -> []+    | otherwise = []+  where accessible n = case lookupDefAccExact n False (tt_ctxt ist) of+                            Just (_, Hidden) -> False+                            _ -> True++-- Try again to solve auto implicits+solveAuto :: IState -> Name -> Bool -> Name -> ElabD ()+solveAuto ist fn ambigok n+           = do hs <- get_holes+                tm <- get_term+                when (n `elem` hs) $ do+                  focus n+                  g <- goal+                  isg <- is_guess -- if it's a guess, we're working on it recursively, so stop+                  when (not isg) $+                    proofSearch' ist True ambigok 100 True Nothing fn []++solveAutos :: IState -> Name -> Bool -> ElabD ()+solveAutos ist fn ambigok+           = do autos <- get_autos+                mapM_ (solveAuto ist fn ambigok) (map fst autos)++trivial' ist+    = trivial (elab ist toplevel ERHS [] (sMN 0 "tac")) ist+trivialHoles' h ist+    = trivialHoles h (elab ist toplevel ERHS [] (sMN 0 "tac")) ist+proofSearch' ist rec ambigok depth prv top n hints+    = do unifyProblems+         proofSearch rec prv ambigok (not prv) depth+                     (elab ist toplevel ERHS [] (sMN 0 "tac")) top n hints ist++-- | Resolve type classes. This will only pick up 'normal' instances, never+-- named instances (which is enforced by 'findInstances').+resolveTC :: Bool -- ^ using default Int+          -> Bool -- ^ allow metavariables in the goal+          -> Int -- ^ depth+          -> Term -- ^ top level goal, for error messages+          -> Name -- ^ top level function name, to prevent loops+          -> IState -> ElabD ()+resolveTC def mvok depth top fn ist+   = do hs <- get_holes+        resTC' [] def hs depth top fn ist++resTC' tcs def topholes 0 topg fn ist = fail $ "Can't resolve type class"+resTC' tcs def topholes 1 topg fn ist = try' (trivial' ist) (resolveTC def False 0 topg fn ist) True+resTC' tcs defaultOn topholes depth topg fn ist+  = do compute+       g <- goal+       -- Resolution can proceed only if there is something concrete in the+       -- determining argument positions. Keep track of the holes in the+       -- non-determining position, because it's okay for 'trivial' to solve+       -- those holes and no others.+       let (argsok, okholePos) = case tcArgsOK g topholes of+                                    Nothing -> (False, [])+                                    Just hs -> (True, hs)+       if not argsok -- && not mvok)+         then lift $ tfail $ CantResolve True topg+         else do+           ptm <- get_term+           ulog <- getUnifyLog+           hs <- get_holes+           env <- get_env+           t <- goal+           let (tc, ttypes) = unApply (getRetTy t)+           let okholes = case tc of+                              P _ n _ -> zip (repeat n) okholePos+                              _ -> []++           traceWhen ulog ("Resolving class " ++ show g ++ "\nin" ++ show env ++ "\n" ++ show okholes) $+            try' (trivialHoles' okholes ist)+                (do addDefault t tc ttypes+                    let stk = elab_stack ist+                    let insts = findInstances ist t+                    tm <- get_term+                    blunderbuss t depth stk (stk ++ insts)) True+  where+    -- returns Just hs if okay, where hs are holes which are okay in the+    -- goal, or Nothing if not okay to proceed+    tcArgsOK ty hs | (P _ nc _, as) <- unApply (getRetTy ty), nc == numclass && defaultOn+       = Just []+    tcArgsOK ty hs -- if any determining arguments are metavariables, postpone+       = let (f, as) = unApply (getRetTy ty) in+             case f of+                  P _ cn _ -> case lookupCtxtExact cn (idris_classes ist) of+                                   Just ci -> tcDetArgsOK 0 (class_determiners ci) hs as+                                   Nothing -> if any (isMeta hs) as+                                                 then Nothing+                                                 else Just []+                  _ -> if any (isMeta hs) as+                          then Nothing+                          else Just []++    -- return the list of argument positions which can safely be a hole+    -- or Nothing if one of the determining arguments is a hole+    tcDetArgsOK i ds hs (x : xs)+        | i `elem` ds = if isMeta hs x+                           then Nothing+                           else tcDetArgsOK (i + 1) ds hs xs+        | otherwise = do rs <- tcDetArgsOK (i + 1) ds hs xs+                         case x of+                              P _ n _ -> Just (i : rs)+                              _ -> Just rs+    tcDetArgsOK _ _ _ [] = Just []++    isMeta :: [Name] -> Term -> Bool+    isMeta ns (P _ n _) = n `elem` ns +    isMeta _ _ = False++    notHole hs (P _ n _, c)+       | (P _ cn _, _) <- unApply (getRetTy c),+         n `elem` hs && isConName cn (tt_ctxt ist) = False+       | Constant _ <- c = not (n `elem` hs)+    notHole _ _ = True++    -- HACK! Rather than giving a special name, better to have some kind+    -- of flag in ClassInfo structure+    chaser (UN nm)+        | ('@':'@':_) <- str nm = True -- old way+    chaser (SN (ParentN _ _)) = True+    chaser (NS n _) = chaser n+    chaser _ = False++    numclass = sNS (sUN "Num") ["Classes","Prelude"]++    addDefault t num@(P _ nc _) [P Bound a _] | nc == numclass && defaultOn+        = do focus a+             fill (RConstant (AType (ATInt ITBig))) -- default Integer+             solve+    addDefault t f as+          | all boundVar as = return () -- True -- fail $ "Can't resolve " ++ show t+    addDefault t f a = return () -- trace (show t) $ return ()++    boundVar (P Bound _ _) = True+    boundVar _ = False++    blunderbuss t d stk [] = do -- c <- get_env+                            -- ps <- get_probs+                            lift $ tfail $ CantResolve False topg+    blunderbuss t d stk (n:ns)+        | n /= fn -- && (n `elem` stk)+              = tryCatch (resolve n d)+                    (\e -> case e of+                             CantResolve True _ -> lift $ tfail e+                             _ -> blunderbuss t d stk ns)+        | otherwise = blunderbuss t d stk ns++    introImps = do g <- goal+                   case g of+                        (Bind _ (Pi _ _ _) sc) -> do attack; intro Nothing+                                                     num <- introImps+                                                     return (num + 1)+                        _ -> return 0++    solven 0 = return ()+    solven n = do solve; solven (n - 1)++    resolve n depth+       | depth == 0 = fail $ "Can't resolve type class"+       | otherwise+           = do lams <- introImps+                t <- goal+                let (tc, ttypes) = trace (show t) $ unApply (getRetTy t)+--                 if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist+--                   else do+                   -- if there's a hole in the goal, don't even try+                let imps = case lookupCtxtName n (idris_implicits ist) of+                                [] -> []+                                [args] -> map isImp (snd args) -- won't be overloaded!+                                xs -> error "The impossible happened - overloading is not expected here!"+                ps <- get_probs+                tm <- get_term+                args <- map snd <$> try' (apply (Var n) imps)+                                         (match_apply (Var n) imps) True+                solven lams -- close any implicit lambdas we introduced+                ps' <- get_probs+                when (length ps < length ps' || unrecoverable ps') $+                     fail "Can't apply type class"+--                 traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $+                mapM_ (\ (_,n) -> do focus n+                                     t' <- goal+                                     let (tc', ttype) = unApply (getRetTy t')+                                     let got = fst (unApply (getRetTy t))+                                     let depth' = if tc' `elem` tcs+                                                     then depth - 1 else depth+                                     resTC' (got : tcs) defaultOn topholes depth' topg fn ist)+                      (filter (\ (x, y) -> not x) (zip (map fst imps) args))+                -- if there's any arguments left, we've failed to resolve+                hs <- get_holes+                ulog <- getUnifyLog+                solve+                traceWhen ulog ("Got " ++ show n) $ return ()+       where isImp (PImp p _ _ _ _) = (True, p)+             isImp arg = (False, priority arg)++collectDeferred :: Maybe Name -> [Name] -> Context ->+                   Term -> State [(Name, (Int, Maybe Name, Type))] Term+collectDeferred top casenames ctxt (Bind n (GHole i t) app) =+    do ds <- get+       t' <- collectDeferred top casenames ctxt t+       when (not (n `elem` map fst ds)) $ put (ds ++ [(n, (i, top, tidyArg [] t'))])+       collectDeferred top casenames ctxt app+  where+    -- Evaluate the top level functions in arguments, if possible, and if it's+    -- not a name we're immediately going to define in a case block, so that+    -- any immediate specialisation of the function applied to constructors +    -- can be done+    tidyArg env (Bind n b@(Pi im t k) sc) +        = Bind n (Pi im (tidy ctxt env t) k)+                 (tidyArg ((n, b) : env) sc)+    tidyArg env t = t++    tidy ctxt env t | (f, args) <- unApply t,+                      P _ specn _ <- getFn f,+                      n `notElem` casenames+        = fst $ specialise ctxt env [(specn, 99999)] t +    tidy ctxt env t@(Bind n (Let _ _) sct)+                    | (f, args) <- unApply sct,+                      P _ specn _ <- getFn f,+                      n `notElem` casenames+        = fst $ specialise ctxt env [(specn, 99999)] t +    tidy ctxt env t = t++    getFn (Bind n (Lam _) t) = getFn t+    getFn t | (f, a) <- unApply t = f++collectDeferred top ns ctxt (Bind n b t) +     = do b' <- cdb b+          t' <- collectDeferred top ns ctxt t+          return (Bind n b' t')+  where+    cdb (Let t v)   = liftM2 Let (collectDeferred top ns ctxt t) (collectDeferred top ns ctxt v)+    cdb (Guess t v) = liftM2 Guess (collectDeferred top ns ctxt t) (collectDeferred top ns ctxt v)+    cdb b           = do ty' <- collectDeferred top ns ctxt (binderTy b)+                         return (b { binderTy = ty' })+collectDeferred top ns ctxt (App s f a) = liftM2 (App s) (collectDeferred top ns ctxt f) +                                                         (collectDeferred top ns ctxt a)+collectDeferred top ns ctxt t = return t++case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()+case_ ind autoSolve ist fn tm = do+  attack+  tyn <- getNameFrom (sMN 0 "ity")+  claim tyn RType+  valn <- getNameFrom (sMN 0 "ival")+  claim valn (Var tyn)+  letn <- getNameFrom (sMN 0 "irule")+  letbind letn (Var tyn) (Var valn)+  focus valn+  elab ist toplevel ERHS [] (sMN 0 "tac") tm+  env <- get_env+  let (Just binding) = lookup letn env+  let val = binderVal binding+  if ind then induction (forget val)+         else casetac (forget val)+  when autoSolve solveAll+++runTactical :: IState -> FC -> Env -> Term -> ElabD ()+runTactical ist fc env tm = do tm' <- eval tm+                               runTacTm tm'+                               return ()+  where+    eval tm = do ctxt <- get_context+                 return $ normaliseAll ctxt env (finalise tm)++    returnUnit = return $ P (DCon 0 0 False) unitCon (P (TCon 0 0) unitTy Erased)++    patvars :: [Name] -> Term -> ([Name], Term)+    patvars ns (Bind n (PVar t) sc) = patvars (n : ns) (instantiate (P Bound n t) sc)+    patvars ns tm                   = (ns, tm)++    pullVars :: (Term, Term) -> ([Name], Term, Term)+    pullVars (lhs, rhs) = (fst (patvars [] lhs), snd (patvars [] lhs), snd (patvars [] rhs)) -- TODO alpha-convert rhs++    defineFunction :: RFunDefn -> ElabD ()+    defineFunction (RDefineFun n clauses) =+      do ctxt <- get_context+         ty <- maybe (fail "no type decl") return $ lookupTyExact n ctxt+         let info = CaseInfo True True False -- TODO document and figure out+         clauses' <- forM clauses (\case+                                      RMkFunClause lhs rhs ->+                                        do lhs' <- fmap fst . lift $ check ctxt [] lhs+                                           rhs' <- fmap fst . lift $ check ctxt [] rhs+                                           return $ Right (lhs', rhs')+                                      RMkImpossibleClause lhs ->+                                        do lhs' <- fmap fst . lift $ check ctxt [] lhs+                                           return $ Left lhs')+         let clauses'' = map (\case Right c -> pullVars c+                                    Left lhs -> let (ns, lhs') = patvars [] lhs'+                                                in (ns, lhs', Impossible))+                            clauses'+         set_context $+           addCasedef n (const [])+                      info False (STerm Erased)+                      True False -- TODO what are these?+                      (map snd $ getArgTys ty) [] -- TODO inaccessible types+                      clauses'+                      clauses''+                      clauses''+                      clauses''+                      clauses''+                      ty+                      ctxt+         updateAux $ \e -> e { new_tyDecls = RClausesInstrs n clauses'' : new_tyDecls e}+         return ()++    -- | Do a step in the reflected elaborator monad. The input is the+    -- step, the output is the (reflected) term returned.+    runTacTm :: Term -> ElabD Term+    runTacTm (unApply -> tac@(P _ n _, args))+      | n == tacN "prim__Solve", [] <- args+      = do solve+           returnUnit+      | n == tacN "prim__Goal", [] <- args+      = do (h:_) <- get_holes+           t <- goal+           fmap fst . get_type_val $+             rawPair (Var (reflm "TTName"), Var (reflm "TT"))+                     (reflectName h,        reflect t)+      | n == tacN "prim__Holes", [] <- args+      = do hs <- get_holes+           fmap fst . get_type_val $+             mkList (Var $ reflm "TTName") (map reflectName hs)+      | n == tacN "prim__Guess", [] <- args+      = do ok <- is_guess+           if ok+              then do guess <- fmap forget get_guess+                      fmap fst . get_type_val $+                        RApp (RApp (Var (sNS (sUN "Just") ["Maybe", "Prelude"]))+                                   (Var (reflm "TT")))+                             guess+              else fmap fst . get_type_val $+                     RApp (Var (sNS (sUN "Nothing") ["Maybe", "Prelude"]))+                          (Var (reflm "TT"))+      | n == tacN "prim__LookupTy", [n] <- args+      = do n' <- reifyTTName n+           ctxt <- get_context+           let getNameTypeAndType = \case Function ty _ -> (Ref, ty)+                                          TyDecl nt ty -> (nt, ty)+                                          Operator ty _ _ -> (Ref, ty)+                                          CaseOp _ ty _ _ _ _ -> (Ref, ty)+               -- Idris tuples nest to the right+               reflectTriple (x, y, z) =+                 raw_apply (Var pairCon) [ Var (reflm "TTName")+                                         , raw_apply (Var pairTy) [Var (reflm "NameType"), Var (reflm "TT")]+                                         , x+                                         , raw_apply (Var pairCon) [ Var (reflm "NameType"), Var (reflm "TT")+                                                                   , y, z]]+           let defs = [ reflectTriple (reflectName n, reflectNameType nt, reflect ty)+                        | (n, def) <- lookupNameDef n' ctxt+                        , let (nt, ty) = getNameTypeAndType def ]+           fmap fst . get_type_val $+             rawList (raw_apply (Var pairTy) [ Var (reflm "TTName")+                                             , raw_apply (Var pairTy) [ Var (reflm "NameType")+                                                                       , Var (reflm "TT")]])+                     defs+      | n == tacN "prim__LookupDatatype", [name] <- args+      = do n' <- reifyTTName name+           datatypes <- get_datatypes+           ctxt <- get_context+           fmap fst . get_type_val $+             rawList (Var (tacN "Datatype"))+                     (map reflectDatatype (buildDatatypes ctxt datatypes n'))+      | n == tacN "prim__SourceLocation", [] <- args+      = fmap fst . get_type_val $+          reflectFC fc+      | n == tacN "prim__Env", [] <- args+      = do env <- get_env+           fmap fst . get_type_val $ reflectEnv env+      | n == tacN "prim__Fail", [_a, errs] <- args+      = do errs' <- eval errs+           parts <- reifyReportParts errs'+           lift . tfail $ ReflectionError [parts] (Msg "")+      | n == tacN "prim__PureElab", [_a, tm] <- args+      = return tm+      | n == tacN "prim__BindElab", [_a, _b, first, andThen] <- args+      = do first' <- eval first+           res <- eval =<< runTacTm first'+           next <- eval (App Complete andThen res)+           runTacTm next+      | n == tacN "prim__Try", [_a, first, alt] <- args+      = do first' <- eval first+           alt' <- eval alt+           try' (runTacTm first') (runTacTm alt') True+      | n == tacN "prim__Fill", [raw] <- args+      = do raw' <- reifyRaw =<< eval raw+           fill raw'+           returnUnit+      | n == tacN "prim__Apply", [raw] <- args+      = do raw' <- reifyRaw =<< eval raw+           apply raw' []+           returnUnit+      | n == tacN "prim__Gensym", [hint] <- args+      = do hintStr <- eval hint+           case hintStr of+             Constant (Str h) -> do+               n <- getNameFrom (sMN 0 h)+               fmap fst $ get_type_val (reflectName n)+             _ -> fail "no hint"+      | n == tacN "prim__Claim", [n, ty] <- args+      = do n' <- reifyTTName n+           ty' <- reifyRaw ty+           claim n' ty'+           returnUnit+      | n == tacN "prim__Forget", [tt] <- args+      = do tt' <- reifyTT tt+           fmap fst . get_type_val . reflectRaw $ forget tt'+      | n == tacN "prim__Attack", [] <- args+      = do attack+           returnUnit+      | n == tacN "prim__Rewrite", [rule] <- args+      = do r <- reifyRaw rule+           rewrite r+           returnUnit+      | n == tacN "prim__Focus", [what] <- args+      = do n' <- reifyTTName what+           focus n'+           returnUnit+      | n == tacN "prim__Unfocus", [what] <- args+      = do n' <- reifyTTName what+           movelast n'+           returnUnit+      | n == tacN "prim__Intro", [mn] <- args+      = do n <- case fromTTMaybe mn of+                  Nothing -> return Nothing+                  Just name -> fmap Just $ reifyTTName name+           intro n+           returnUnit+      | n == tacN "prim__Forall", [n, ty] <- args+      = do n' <- reifyTTName n+           ty' <- reifyRaw ty+           forall n' Nothing ty'+           returnUnit+      | n == tacN "prim__PatVar", [n] <- args+      = do n' <- reifyTTName n+           patvar n'+           returnUnit+      | n == tacN "prim__PatBind", [n] <- args+      = do n' <- reifyTTName n+           patbind n'+           returnUnit+      | n == tacN "prim__Compute", [] <- args+      = do compute ; returnUnit+      | n == tacN "prim__DeclareType", [decl] <- args+      = do (RDeclare n args res) <- reifyTyDecl decl+           ctxt <- get_context+           let mkPi arg res = RBind (argName arg)+                                    (Pi Nothing (argTy arg) (RUType AllTypes))+                                    res+               rty = foldr mkPi res args+           (checked, ty') <- lift $ check ctxt [] rty+           case normaliseAll ctxt [] (finalise ty') of+             UType _ -> return ()+             TType _ -> return ()+             ty''    -> lift . tfail . InternalMsg $+                          show checked ++ " is not a type: it's " ++ show ty''+           case lookupDefExact n ctxt of+             Just _ -> lift . tfail . InternalMsg $+                         show n ++ " is already defined."+             Nothing -> return ()+           let decl = TyDecl Ref checked+               ctxt' = addCtxtDef n decl ctxt+           set_context ctxt'+           updateAux $ \e -> e { new_tyDecls = (RTyDeclInstrs n fc (map rArgToPArg args) checked) :+                                               new_tyDecls e }+           aux <- getAux+           returnUnit+      | n == tacN "prim__DefineFunction", [decl] <- args+      = do defn <- reifyFunDefn decl+           defineFunction defn+           returnUnit+      | n == tacN "prim__AddInstance", [cls, inst] <- args+      = do className <- reifyTTName cls+           instName <- reifyTTName inst+           updateAux $ \e -> e { new_tyDecls = RAddInstance className instName :+                                               new_tyDecls e}+           returnUnit+      | n == tacN "prim__ResolveTC", [fn] <- args+      = do g <- goal+           fn <- reifyTTName fn+           resolveTC False True 100 g fn ist+           returnUnit+      | n == tacN "prim__RecursiveElab", [goal, script] <- args+      = do goal' <- reifyRaw goal+           ctxt <- get_context+           script <- eval script+           (goalTT, goalTy) <- lift $ check ctxt [] goal'+           lift $ isType ctxt [] goalTy+           recH <- getNameFrom (sMN 0 "recElabHole")+           aux <- getAux+           datatypes <- get_datatypes+           env <- get_env+           (_, ES (p, aux') _ _) <-+              lift $ runElab aux (runTactical ist fc [] script)+                             (newProof recH ctxt datatypes goalTT)+           let tm_out = getProofTerm (pterm p)+           updateAux $ const aux'+           env' <- get_env+           (tm, ty, _) <- lift $ recheck ctxt env (forget tm_out) tm_out+           let (tm', ty') = (reflect tm, reflect ty)+           fmap fst . get_type_val $+             rawPair (Var $ reflm "TT", Var $ reflm "TT")+                     (tm', ty')+      | n == tacN "prim__Debug", [ty, msg] <- args+      = do let msg' = fromTTMaybe msg+           case msg' of+             Nothing -> debugElaborator Nothing+             Just (Constant (Str m)) -> debugElaborator (Just m)+             Just x -> lift . tfail . InternalMsg $ "Can't reify message for debugging: " ++ show x+    runTacTm x = lift . tfail $ ElabScriptStuck x++-- Running tactics directly+-- if a tactic adds unification problems, return an error++runTac :: Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()+runTac autoSolve ist perhapsFC fn tac+    = do env <- get_env+         g <- goal+         let tac' = fmap (addImplBound ist (map fst env)) tac+         if autoSolve+            then runT tac'+            else no_errors (runT tac')+                   (Just (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env)))+  where+    runT (Intro []) = do g <- goal+                         attack; intro (bname g)+      where+        bname (Bind n _ _) = Just n+        bname _ = Nothing+    runT (Intro xs) = mapM_ (\x -> do attack; intro (Just x)) xs+    runT Intros = do g <- goal+                     attack; +                     intro (bname g)+                     try' (runT Intros)+                          (return ()) True+      where+        bname (Bind n _ _) = Just n+        bname _ = Nothing+    runT (Exact tm) = do elab ist toplevel ERHS [] (sMN 0 "tac") tm+                         when autoSolve solveAll+    runT (MatchRefine fn)+        = do fnimps <-+               case lookupCtxtName fn (idris_implicits ist) of+                    [] -> do a <- envArgs fn+                             return [(fn, a)]+                    ns -> return (map (\ (n, a) -> (n, map (const True) a)) ns)+             let tacs = map (\ (fn', imps) ->+                                 (match_apply (Var fn') (map (\x -> (x, 0)) imps),+                                     fn')) fnimps+             tryAll tacs+             when autoSolve solveAll+       where envArgs n = do e <- get_env+                            case lookup n e of+                               Just t -> return $ map (const False)+                                                      (getArgTys (binderTy t))+                               _ -> return []+    runT (Refine fn [])+        = do fnimps <-+               case lookupCtxtName fn (idris_implicits ist) of+                    [] -> do a <- envArgs fn+                             return [(fn, a)]+                    ns -> return (map (\ (n, a) -> (n, map isImp a)) ns)+             let tacs = map (\ (fn', imps) ->+                                 (apply (Var fn') (map (\x -> (x, 0)) imps),+                                     fn')) fnimps+             tryAll tacs+             when autoSolve solveAll+       where isImp (PImp _ _ _ _ _) = True+             isImp _ = False+             envArgs n = do e <- get_env+                            case lookup n e of+                               Just t -> return $ map (const False)+                                                      (getArgTys (binderTy t))+                               _ -> return []+    runT (Refine fn imps) = do ns <- apply (Var fn) (map (\x -> (x,0)) imps)+                               when autoSolve solveAll+    runT DoUnify = do unify_all+                      when autoSolve solveAll+    runT (Claim n tm) = do tmHole <- getNameFrom (sMN 0 "newGoal")+                           claim tmHole RType+                           claim n (Var tmHole)+                           focus tmHole+                           elab ist toplevel ERHS [] (sMN 0 "tac") tm+                           focus n+    runT (Equiv tm) -- let bind tm, then+              = do attack+                   tyn <- getNameFrom (sMN 0 "ety")+                   claim tyn RType+                   valn <- getNameFrom (sMN 0 "eqval")+                   claim valn (Var tyn)+                   letn <- getNameFrom (sMN 0 "equiv_val")+                   letbind letn (Var tyn) (Var valn)+                   focus tyn+                   elab ist toplevel ERHS [] (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 <- getNameFrom (sMN 0 "rty")+                   -- start_unify h+                   claim tyn RType+                   valn <- getNameFrom (sMN 0 "rval")+                   claim valn (Var tyn)+                   letn <- getNameFrom (sMN 0 "rewrite_rule")+                   letbind letn (Var tyn) (Var valn)+                   focus valn+                   elab ist toplevel ERHS [] (sMN 0 "tac") tm+                   rewrite (Var letn)+                   when autoSolve solveAll+    runT (Induction tm) -- let bind tm, similar to the others+              = case_ True autoSolve ist fn tm+    runT (CaseTac tm)+              = case_ False autoSolve ist fn tm+    runT (LetTac n tm)+              = do attack+                   tyn <- getNameFrom (sMN 0 "letty")+                   claim tyn RType+                   valn <- getNameFrom (sMN 0 "letval")+                   claim valn (Var tyn)+                   letn <- unique_hole n+                   letbind letn (Var tyn) (Var valn)+                   focus valn+                   elab ist toplevel ERHS [] (sMN 0 "tac") tm+                   when autoSolve solveAll+    runT (LetTacTy n ty tm)+              = do attack+                   tyn <- getNameFrom (sMN 0 "letty")+                   claim tyn RType+                   valn <- getNameFrom (sMN 0 "letval")+                   claim valn (Var tyn)+                   letn <- unique_hole n+                   letbind letn (Var tyn) (Var valn)+                   focus tyn+                   elab ist toplevel ERHS [] (sMN 0 "tac") ty+                   focus valn+                   elab ist toplevel ERHS [] (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 rec prover depth top hints)+         = do proofSearch' ist rec False depth prover top fn hints+              when autoSolve solveAll+    runT (Focus n) = focus n+    runT Unfocus = do hs <- get_holes+                      case hs of+                        []      -> return ()+                        (h : _) -> movelast h+    runT Solve = solve+    runT (Try l r) = do try' (runT l) (runT r) True+    runT (TSeq l r) = do runT l; runT r+    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 <- getNameFrom (sMN 0 "script")+                               claim script scriptTy+                               scriptvar <- getNameFrom (sMN 0 "scriptvar" )+                               letbind scriptvar scriptTy (Var script)+                               focus script+                               elab ist toplevel ERHS [] (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 <- getNameFrom (sMN 0 "restac")+                               claim restac tacticTy+                               focus restac+                               fill (raw_apply (forget script')+                                               [reflectEnv tenv, reflect tgoal])+                               restac' <- get_guess+                               solve+                               -- normalise the result in order to+                               -- reify it+                               ctxt <- get_context+                               env <- get_env+                               let tactic = normalise ctxt env restac'+                               runReflected tactic+        where tacticTy = Var (reflm "Tactic")+              listTy = Var (sNS (sUN "List") ["List", "Prelude"])+              scriptTy = (RBind (sMN 0 "__pi_arg")+                                (Pi Nothing (RApp listTy envTupleType) RType)+                                    (RBind (sMN 1 "__pi_arg")+                                           (Pi Nothing (Var $ reflm "TT") RType) 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 ERHS [] (sMN 0 "tac")+                  (PApp emptyFC tm [pexp (delabTy' ist [] tgoal True True)])+             (script', _) <- get_type_val (Var scriptvar)+             -- now that we have the script apply+             -- it to the reflected goal+             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 <- getNameFrom (sMN 0 "letty")+                          claim tyn RType+                          valn <- getNameFrom (sMN 0 "letval")+                          claim valn (Var tyn)+                          letn <- getNameFrom (sMN 0 "letvar")+                          letbind letn (Var tyn) (Var valn)+                          focus valn+                          elab ist toplevel ERHS [] (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 perhapsFC fn (Exact $ PQuote (reflect value'))+    runT (Fill v) = do attack -- let x = fill x in ...+                       tyn <- getNameFrom (sMN 0 "letty")+                       claim tyn RType+                       valn <- getNameFrom (sMN 0 "letval")+                       claim valn (Var tyn)+                       letn <- getNameFrom (sMN 0 "letvar")+                       letbind letn (Var tyn) (Var valn)+                       focus valn+                       elab ist toplevel ERHS [] (sMN 0 "tac") v+                       (value, _) <- get_type_val (Var letn)+                       ctxt <- get_context+                       env <- get_env+                       let value' = normalise ctxt env value+                       rawValue <- reifyRaw value'+                       runTac autoSolve ist perhapsFC fn (Exact $ PQuote rawValue)+    runT (GoalType n tac) = do g <- goal+                               case unApply g of+                                    (P _ n' _, _) ->+                                       if nsroot n' == sUN n+                                          then runT tac+                                          else fail "Wrong goal type"+                                    _ -> fail "Wrong goal type"+    runT ProofState = do g <- goal+                         return ()+    runT Skip = return ()+    runT (TFail err) = lift . tfail $ ReflectionError [err] (Msg "")+    runT SourceFC =+      case perhapsFC of+        Nothing -> lift . tfail $ Msg "There is no source location available."+        Just fc ->+          do fill $ reflectFC fc+             solve+    runT Qed = lift . tfail $ Msg "The qed command is only valid in the interactive prover"+    runT x = fail $ "Not implemented " ++ show x++    runReflected t = do t' <- reify ist t+                        runTac autoSolve ist perhapsFC fn t'++elaboratingArgErr :: [(Name, Name)] -> Err -> Err+elaboratingArgErr [] err = err+elaboratingArgErr ((f,x):during) err = fromMaybe err (rewrite err)+  where rewrite (ElaboratingArg _ _ _ _) = Nothing+        rewrite (ProofSearchFail e) = fmap ProofSearchFail (rewrite e)+        rewrite (At fc e) = fmap (At fc) (rewrite e)+        rewrite err = Just (ElaboratingArg f x during err)+++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+          -- At and Elaborating are just plumbing - error reflection shouldn't rewrite them+          handle e@(At fc err) = do logLvl 3 "Reflecting body of At"+                                    err' <- handle err+                                    return (At fc err')+          handle e@(Elaborating what n err) = do logLvl 3 "Reflecting body of Elaborating"+                                                 err' <- handle err+                                                 return (Elaborating what n err')+          handle e@(ElaboratingArg f a prev err) = do logLvl 3 "Reflecting body of ElaboratingArg"+                                                      hs <- getFnHandlers f a+                                                      err' <- if null hs+                                                                 then handle err+                                                                 else applyHandlers err hs+                                                      return (ElaboratingArg f a prev err')+          -- ProofSearchFail is an internal detail - so don't expose it+          handle (ProofSearchFail e) = handle e+          -- TODO: argument-specific error handlers go here for ElaboratingArg+          handle e = do ist <- getIState+                        logLvl 2 "Starting error reflection"+                        let handlers = idris_errorhandlers ist+                        applyHandlers e handlers+          getFnHandlers :: Name -> Name -> Idris [Name]+          getFnHandlers f arg = do ist <- getIState+                                   let funHandlers = maybe M.empty id .+                                                     lookupCtxtExact f .+                                                     idris_function_errorhandlers $ ist+                                   return . maybe [] S.toList . M.lookup arg $ funHandlers+++          applyHandlers e handlers =+                      do ist <- getIState+                         let err = fmap (errReverse ist) e+                         logLvl 3 $ "Using reflection handlers " +++                                    concat (intersperse ", " (map show handlers))+                         let reports = map (\n -> RApp (Var n) (reflectErr err)) 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++solveAll = try (do solve; solveAll) (return ())++-- | Do the left-over work after creating declarations in reflected+-- elaborator scripts+processTacticDecls :: ElabInfo -> [RDeclInstructions] -> Idris ()+processTacticDecls info steps =+  -- The order of steps is important: type declarations might+  -- establish metavars that later function bodies resolve.+  forM_ (reverse steps) $ \case+    RTyDeclInstrs n fc impls ty ->+      do logLvl 3 $ "Declaration from tactics: " ++ show n ++ " : " ++ show ty+         logLvl 3 $ "  It has impls " ++ show impls+         updateIState $ \i -> i { idris_implicits =+                                    addDef n impls (idris_implicits i) }+         addIBC (IBCImp n)+         ds <- checkDef fc (\_ e -> e) [(n, (-1, Nothing, ty))]+         addIBC (IBCDef n)+         ctxt <- getContext+         case lookupDef n ctxt of+           (TyDecl _ _ : _) ->+             -- If the function isn't defined at the end of the elab script,+             -- then it must be added as a metavariable. This needs guarding+             -- to prevent overwriting case defs with a metavar, if the case+             -- defs come after the type decl in the same script!+             let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds+             in addDeferred ds'+           _ -> return ()+    RAddInstance className instName ->+      do -- The type class resolution machinery relies on a special +         logLvl 2 $ "Adding elab script instance " ++ show instName +++                    " for " ++ show className+         addInstance False True className instName+         addIBC (IBCInstance False True className instName)+    RClausesInstrs n cs ->+      do logLvl 3 $ "Pattern-matching definition from tactics: " ++ show n+         solveDeferred n+         let lhss = map (\(_, lhs, _) -> lhs) cs+         let fc = fileFC "elab_reflected"+         pmissing <-+           do ist <- getIState+              possible <- genClauses fc n lhss+                                     (map (\lhs ->+                                        delab' ist lhs True True) lhss)+              missing <- filterM (checkPossible n) possible+              return (filter (noMatch ist lhss) missing)+         let tot = if null pmissing+                      then Unchecked -- still need to check recursive calls+                      else Partial NotCovering -- missing cases implies not total+         setTotality n tot+         updateIState $ \i -> i { idris_patdefs =+                                    addDef n (cs, pmissing) $ idris_patdefs i }+         addIBC (IBCDef n)++         ctxt <- getContext+         case lookupDefExact n ctxt of+           Just (CaseOp _ _ _ _ _ cd) ->+             -- Here, we populate the call graph with a list of things+             -- we refer to, so that if they aren't total, the whole+             -- thing won't be.+             let (scargs, sc) = cases_compiletime cd+                 (scargs', sc') = cases_runtime cd+                 calls = findCalls sc' scargs+                 used = findUsedArgs sc' scargs'+                 cg = CGInfo scargs' calls [] used []+             in do logLvl 2 $ "Called names in reflected elab: " ++ show cg+                   addToCG n cg+                   addToCalledG n (nub (map fst calls))+                   addIBC $ IBCCG n+           Just _ -> return () -- TODO throw internal error+           Nothing -> return ()++         -- checkDeclTotality requires that the call graph be present+         -- before calling it.+         -- TODO: reduce code duplication with Idris.Elab.Clause+         buildSCG (fc, n)++         -- Actually run the totality checker. In the main clause+         -- elaborator, this is deferred until after. Here, we run it+         -- now to get totality information as early as possible.+         tot' <- checkDeclTotality (fc, n)+         setTotality n tot'+         when (tot' /= Unchecked) $ addIBC (IBCTotal n tot')+  where+    -- TODO: see if the code duplication with Idris.Elab.Clause can be+    -- reduced or eliminated.+    checkPossible :: Name -> PTerm -> Idris Bool+    checkPossible fname lhs_in =+       do ctxt <- getContext+          ist <- getIState+          let lhs = addImplPat ist lhs_in+          let fc = fileFC "elab_reflected_totality"+          let tcgen = False -- TODO: later we may support dictionary generation+          case elaborate ctxt (idris_datatypes ist) (sMN 0 "refPatLHS") infP initEState+                (erun fc (buildTC ist info ELHS [] fname (infTerm lhs))) of+            OK (ElabResult lhs' _ _ _ _ _, _) ->+              do -- not recursively calling here, because we don't+                 -- want to run infinitely many times+                 let lhs_tm = orderPats (getInferTerm lhs')+                 case recheck ctxt [] (forget lhs_tm) lhs_tm of+                      OK _ -> return True+                      err -> return False+            -- if it's a recoverable error, the case may become possible+            Error err -> if tcgen then return (recoverableCoverage ctxt err)+                                  else return (validCoverageCase ctxt err ||+                                                 recoverableCoverage ctxt err)+++    -- TODO: Attempt to reduce/eliminate code duplication with Idris.Elab.Clause+    noMatch i cs tm = all (\x -> case matchClause i (delab' i x True True) tm of+                                   Right _ -> False+                                   Left  _ -> True) cs
src/Idris/Elab/Transform.hs view
@@ -7,7 +7,6 @@ import Idris.Error import Idris.Delaborate import Idris.Imports-import Idris.ElabTerm import Idris.Coverage import Idris.DataOpts import Idris.Providers@@ -15,10 +14,11 @@ import Idris.Inliner import Idris.PartialEval import Idris.DeepSeq-import Idris.Output (iputStrLn, pshow, iWarn)+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting) import IRTS.Lang  import Idris.Elab.Utils+import Idris.Elab.Term  import Idris.Core.TT import Idris.Core.Elaborate hiding (Tactic(..))@@ -53,12 +53,13 @@     = do ctxt <- getContext          i <- getIState          let lhs = addImplPat i lhs_in-         (ElabResult lhs' dlhs [] ctxt' newDecls, _) <--              tclift $ elaborate ctxt (sMN 0 "transLHS") infP initEState+         (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-+              tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transLHS") infP initEState                        (erun fc (buildTC i info ELHS [] (sUN "transform")                                    (infTerm lhs)))          setContext ctxt'-         processTacticDecls newDecls+         processTacticDecls info newDecls+         sendHighlighting highlights          let lhs_tm = orderPats (getInferTerm lhs')          let lhs_ty = getInferType lhs'          let newargs = pvars i lhs_tm@@ -69,16 +70,17 @@           let rhs = addImplBound i (map fst newargs) rhs_in          ((rhs', defer, ctxt', newDecls), _) <--              tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty initEState+              tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transRHS") clhs_ty initEState                        (do pbinds i lhs_tm                            setNextName-                           (ElabResult _ _ _ ctxt' newDecls) <- erun fc (build i info ERHS [] (sUN "transform") rhs)+                           (ElabResult _ _ _ ctxt' newDecls highlights) <- erun fc (build i info ERHS [] (sUN "transform") rhs)                            erun fc $ psolve lhs_tm                            tt <- get_term-                           let (rhs', defer) = runState (collectDeferred Nothing tt) []+                           let (rhs', defer) = runState (collectDeferred Nothing [] ctxt tt) []                            return (rhs', defer, ctxt', newDecls))          setContext ctxt'-         processTacticDecls newDecls+         processTacticDecls info newDecls+         sendHighlighting highlights           (crhs_tm_in, crhs_ty) <- recheckC fc id [] rhs'          let crhs_tm = renamepats pnames crhs_tm_in
src/Idris/Elab/Type.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-}-module Idris.Elab.Type (buildType, elabType, elabType', elabPostulate) where+module Idris.Elab.Type (buildType, elabType, elabType', +                        elabPostulate, elabExtern) where  import Idris.AbsSyntax import Idris.ASTUtils@@ -7,7 +8,7 @@ import Idris.Error import Idris.Delaborate import Idris.Imports-import Idris.ElabTerm+import Idris.Elab.Term import Idris.Coverage import Idris.DataOpts import Idris.Providers@@ -15,7 +16,7 @@ import Idris.Inliner import Idris.PartialEval import Idris.DeepSeq-import Idris.Output (iputStrLn, pshow, iWarn)+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting) import IRTS.Lang  import Idris.Elab.Utils@@ -65,11 +66,12 @@          logLvl 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'          logLvl 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty -         (ElabResult tyT' defer is ctxt' newDecls, log) <--            tclift $ elaborate ctxt n (TType (UVal 0)) initEState+         (ElabResult tyT' defer is ctxt' newDecls highlights, log) <-+            tclift $ elaborate ctxt (idris_datatypes i) n (TType (UVal 0)) initEState                      (errAt "type of " n (erun fc (build i info ETyDecl [] n ty)))          setContext ctxt'-         processTacticDecls newDecls+         processTacticDecls info newDecls+         sendHighlighting highlights           let tyT = patToImp tyT' @@ -78,7 +80,8 @@          ds <- checkAddDef True False fc iderr defer          -- if the type is not complete, note that we'll need to infer          -- things later (for solving metavariables)-         when (not (null ds)) $ addTyInferred n+         when (length ds > length is) -- more deferred than case blocks+              $ addTyInferred n           mapM_ (elabCaseBlock info opts) is          ctxt <- getContext@@ -118,14 +121,16 @@ -- | Elaborate a top-level type declaration - for example, "foo : Int -> Int". elabType :: ElabInfo -> SyntaxInfo          -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))]-         -> FC -> FnOpts -> Name -> PTerm -> Idris Type+         -> FC -> FnOpts+         -> Name -> FC -- ^ The precise location of the name+         -> PTerm -> Idris Type elabType = elabType' False  elabType' :: Bool -> -- normalise it              ElabInfo -> SyntaxInfo ->              Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] ->-             FC -> FnOpts -> Name -> PTerm -> Idris Type-elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in+             FC -> FnOpts -> Name -> FC -> PTerm -> Idris Type+elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (params info) ty_in                                                        n  = liftname info n_in in    -}       do checkUndefined fc n          (cty, _, ty, inacc) <- buildType info syn fc opts n ty'@@ -145,8 +150,8 @@            addInternalApp (fc_fname fc) (fst . fc_start $ fc) ty' -- (mergeTy ty' (delab i nty')) -- TODO: Should use span instead of line and filename?            addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) ty') -- (mergeTy ty' (delab i nty'))) -         let (t, _) = unApply (getRetTy nty')-         let corec = case t of+         let (fam, _) = unApply (getRetTy nty')+         let corec = case fam of                         P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of                                         [TI _ True _ _ _] -> True                                         _ -> False@@ -156,7 +161,7 @@          let usety = if norm then nty' else nty          ds <- checkDef fc iderr [(n, (-1, Nothing, usety))]          addIBC (IBCDef n)-         let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds+         let ds' = map (\(n, (i, top, fam)) -> (n, (i, top, fam, True))) ds          addDeferred ds'          setFlags n opts'          checkDocs fc argDocs ty@@ -170,6 +175,11 @@          addIBC (IBCOpt n)          when (Implicit `elem` opts') $ do addCoercion n                                            addIBC (IBCCoercion n)+         when (AutoHint `elem` opts') $ +             case fam of+                P _ tyn _ -> do addAutoHint tyn n+                                addIBC (IBCAutoHint tyn n)+                t -> ifail $ "Hints must return a data or record type"           -- If the function is declared as an error handler and the language          -- extension is enabled, then add it to the list of error handlers.@@ -185,6 +195,8 @@                          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."+         -- Send highlighting information about the name being declared+         sendHighlighting [(nfc, AnnName n Nothing Nothing Nothing)]          -- if it's an export list type, make a note of it          case (unApply usety) of               (P _ ut _, _) @@ -196,8 +208,8 @@     -- for making an internalapp, we only want the explicit ones, and don't     -- want the parameters, so just take the arguments which correspond to the     -- user declared explicit ones-    mergeTy (PPi e n ty sc) (PPi e' n' _ sc')-         | e == e' = PPi e n ty (mergeTy sc sc')+    mergeTy (PPi e n fc ty sc) (PPi e' n' _ _ sc')+         | e == e' = PPi e n fc ty (mergeTy sc sc')          | otherwise = mergeTy sc sc'     mergeTy _ sc = sc @@ -209,8 +221,8 @@     errrep = txt "ErrorReportPart"      tyIsHandler (Bind _ (Pi _ (P _ (NS (UN e) ns1) _) _)-                        (App (P _ (NS (UN m) ns2) _)-                             (App (P _ (NS (UN l) ns3) _)+                        (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"]@@ -222,9 +234,22 @@ elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->                  FC -> FnOpts -> Name -> PTerm -> Idris () elabPostulate info syn doc fc opts n ty = do-    elabType info syn doc [] fc opts n ty+    elabType info syn doc [] fc opts n NoFC ty     putIState . (\ist -> ist{ idris_postulates = S.insert n (idris_postulates ist) }) =<< getIState     addIBC (IBCPostulate n)++    -- remove it from the deferred definitions list+    solveDeferred n++elabExtern :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->+                 FC -> FnOpts -> Name -> PTerm -> Idris ()+elabExtern info syn doc fc opts n ty = do+    cty <- elabType info syn doc [] fc opts n NoFC ty+    ist <- getIState+    let arity = length (getArgTys (normalise (tt_ctxt ist) [] cty))++    putIState . (\ist -> ist{ idris_externs = S.insert (n, arity) (idris_externs ist) }) =<< getIState+    addIBC (IBCExtern (n, arity))      -- remove it from the deferred definitions list     solveDeferred n
src/Idris/Elab/Utils.hs view
@@ -66,9 +66,9 @@  -- | Get the list of (index, name) of inaccessible arguments from the type. inaccessibleArgs :: Int -> PTerm -> [(Int, Name)]-inaccessibleArgs i (PPi (Imp _ _ _ _) n Placeholder t)+inaccessibleArgs i (PPi (Imp _ _ _ _) n _ Placeholder t)         = (i,n) : inaccessibleArgs (i+1) t  -- unbound implicit-inaccessibleArgs i (PPi plicity n ty t)+inaccessibleArgs i (PPi plicity n _ ty t)     | InaccessibleArg `elem` pargopts plicity         = (i,n) : inaccessibleArgs (i+1) t  -- an .{erased : Implicit}     | otherwise@@ -117,14 +117,14 @@ -- found, or it will give spurious errors. checkDocs :: FC -> [(Name, Docstring a)] -> PTerm -> Idris () checkDocs fc args tm = cd (Map.fromList args) tm-  where cd as (PPi _ n _ sc) = cd (Map.delete n as) sc+  where cd as (PPi _ n _ _ sc) = cd (Map.delete n as) sc         cd as _ | Map.null as = return ()                 | otherwise   = ierror . At fc . Msg $                                 "There is documentation for argument(s) "                                 ++ (concat . intersperse ", " . map show . Map.keys) as                                 ++ " but they were not found." -decorateid decorate (PTy doc argdocs s f o n t) = PTy doc argdocs s f o (decorate n) t+decorateid decorate (PTy doc argdocs s f o n nfc t) = PTy doc argdocs s f o (decorate n) nfc t decorateid decorate (PClauses f o n cs)    = PClauses f o (decorate n) (map dc cs)     where dc (PClause fc n t as w ds) = PClause fc (decorate n) (dappname t) as w ds@@ -171,7 +171,7 @@                     _ -> [] getFixedInType i env (_ : is) (Bind n (Pi _ t _) sc)     = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)-getFixedInType i env is tm@(App f a)+getFixedInType i env is tm@(App _ f a)     | (P _ tn _, args) <- unApply tm        = case lookupCtxt tn (idris_datatypes i) of             [t] -> nub $ paramNames args env (param_pos t) ++@@ -186,27 +186,29 @@ getFlexInType i env ps (Bind n (Pi _ t _) sc)     = nub $ (if (not (n `elem` ps)) then getFlexInType i env ps t else []) ++             getFlexInType i (n : env) ps (instantiate (P Bound n t) sc)-getFlexInType i env ps tm@(App f a)-    | (P _ tn _, args) <- unApply tm++getFlexInType i env ps tm@(App _ f a)+    | (P nt tn _, args) <- unApply tm, nt /= Bound        = case lookupCtxt tn (idris_datatypes i) of             [t] -> nub $ paramNames args env [x | x <- [0..length args],                                                   not (x `elem` param_pos t)]                            ++ getFlexInType i env ps f ++                              getFlexInType i env ps a-            [] -> let ppos = case lookupCtxt tn (idris_fninfo i) of-                                  [fi] -> fn_params fi -                                  [] -> [] in-                      nub $ paramNames args env [x | x <- [0..length args],-                                                     not (x `elem` ppos)] -                            ++ getFlexInType i env ps f ++-                               getFlexInType i env ps a+            [] -> let ppos = case lookupCtxtName tn (idris_fninfo i) of+                                  [fi] -> fn_params (snd fi)+                                  [] -> []+                                  xs -> error ("Too much function info: " ++ show xs)+                  in nub $ paramNames args env [x | x <- [0..length args],+                                                    not (x `elem` ppos)] +                           ++ getFlexInType i env ps f +++                              getFlexInType i env ps a     | otherwise = nub $ getFlexInType i env ps f ++                         getFlexInType i env ps a getFlexInType i _ _ _ = [] --- Treat a name as a parameter if it appears in parameter positions in+-- | Treat a name as a parameter if it appears in parameter positions in -- types, and never in a non-parameter position in a (non-param) argument type.-+getParamsInType :: IState -> [Name] -> [PArg] -> Type -> [Name] getParamsInType i env ps t = let fix = getFixedInType i env ps t                                  flex = getFlexInType i env fix t in                                  [x | x <- fix, not (x `elem` flex)]@@ -232,7 +234,7 @@                          _ -> False in              do getUniqB env us b                 getUniq ((n,b):env) ((n, uniq):us) sc-    getUniq env us (App f a) = do getUniq env us f; getUniq env us a+    getUniq env us (App _ f a) = do getUniq env us f; getUniq env us a     getUniq env us (V i)        | i < length us = if snd (us!!i) then use (fst (us!!i)) else return ()     getUniq env us (P _ n _)@@ -270,14 +272,14 @@ getStatics _ _ = []  mkStatic :: [Name] -> PDecl -> PDecl-mkStatic ns (PTy doc argdocs syn fc o n ty) -    = PTy doc argdocs syn fc o n (mkStaticTy ns ty)+mkStatic ns (PTy doc argdocs syn fc o n nfc ty) +    = PTy doc argdocs syn fc o n nfc (mkStaticTy ns ty) mkStatic ns t = t  mkStaticTy :: [Name] -> PTerm -> PTerm-mkStaticTy ns (PPi p n ty sc) -    | n `elem` ns = PPi (p { pstatic = Static }) n ty (mkStaticTy ns sc)-    | otherwise = PPi p n ty (mkStaticTy ns sc)+mkStaticTy ns (PPi p n fc ty sc) +    | n `elem` ns = PPi (p { pstatic = Static }) n fc ty (mkStaticTy ns sc)+    | otherwise = PPi p n fc ty (mkStaticTy ns sc) mkStaticTy ns t = t
src/Idris/Elab/Value.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}-module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms) where+module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms, elabExec) where  import Idris.AbsSyntax import Idris.ASTUtils@@ -8,7 +8,6 @@ import Idris.Error import Idris.Delaborate import Idris.Imports-import Idris.ElabTerm import Idris.Coverage import Idris.DataOpts import Idris.Providers@@ -16,10 +15,11 @@ import Idris.Inliner import Idris.PartialEval import Idris.DeepSeq-import Idris.Output (iputStrLn, pshow, iWarn)+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting) import IRTS.Lang  import Idris.Elab.Utils+import Idris.Elab.Term  import Idris.Core.TT import Idris.Core.Elaborate hiding (Tactic(..))@@ -63,13 +63,14 @@         --    * elaboration as a Type         --    * elaboration as a function a -> b -        (ElabResult tm' defer is ctxt' newDecls, _) <--             tclift (elaborate ctxt (sMN 0 "val") infP initEState+        (ElabResult tm' defer is ctxt' newDecls highlights, _) <-+             tclift (elaborate ctxt (idris_datatypes i) (sMN 0 "val") infP initEState                      (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))          -- Extend the context with new definitions created         setContext ctxt'-        processTacticDecls newDecls+        processTacticDecls info newDecls+        sendHighlighting highlights          let vtm = orderPats (getInferTerm tm') @@ -114,3 +115,18 @@                                             then Example tm                                             else Checked tm           | otherwise                   = Unchecked++-- Try running the term directly (as IO ()), then printing it as an Integer+-- (as a default numeric tye), then printing it as any Showable thing+elabExec :: FC -> PTerm -> PTerm+elabExec fc tm = runtm (PAlternative FirstSuccess+                   [printtm (PApp fc (PRef fc (sUN "the"))+                     [pexp (PConstant NoFC (AType (ATInt ITBig))), pexp tm]),+                    tm,+                    printtm tm+                    ])+  where+    runtm t = PApp fc (PRef fc (sUN "run__IO")) [pexp t]+    printtm t = PApp fc (PRef fc (sUN "printLn"))+                  [pimp (sUN "ffi") (PRef fc (sUN "FFI_C")) False, pexp t]+
src/Idris/ElabDecls.hs view
@@ -8,8 +8,9 @@ import Idris.DSL import Idris.Error import Idris.Delaborate+import Idris.Directives import Idris.Imports-import Idris.ElabTerm+import Idris.Elab.Term import Idris.Coverage import Idris.DataOpts import Idris.Providers@@ -17,7 +18,7 @@ import Idris.Inliner import Idris.PartialEval import Idris.DeepSeq-import Idris.Output (iputStrLn, pshow, iWarn)+import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting) import IRTS.Lang  import Idris.Elab.Utils@@ -155,22 +156,24 @@      = return () -- nothing to elaborate elabDecl' _ info (PSyntax _ p)      = return () -- nothing to elaborate-elabDecl' what info (PTy doc argdocs s f o n ty)+elabDecl' what info (PTy doc argdocs s f o n nfc ty)   | what /= EDefns     = do iLOG $ "Elaborating type decl " ++ show n ++ show o-         elabType info s doc argdocs f o n ty+         elabType info s doc argdocs f o n nfc ty          return ()-elabDecl' what info (PPostulate doc s f o n ty)+elabDecl' what info (PPostulate b doc s f o n ty)   | what /= EDefns     = do iLOG $ "Elaborating postulate " ++ show n ++ show o-         elabPostulate info s doc f o n ty+         if b +            then elabExtern info s doc f o n ty+            else elabPostulate info s doc f o n ty elabDecl' what info (PData doc argDocs s f co d)   | what /= ETypes     = do iLOG $ "Elaborating " ++ show (d_name d)          elabData info s doc argDocs f co d   | otherwise     = do iLOG $ "Elaborating [type of] " ++ show (d_name d)-         elabData info s doc argDocs f co (PLaterdecl (d_name d) (d_tcon d))+         elabData info s doc argDocs f co (PLaterdecl (d_name d) (d_name_fc d) (d_tcon d)) elabDecl' what info d@(PClauses f o n ps)   | what /= ETypes     = do iLOG $ "Elaborating clause " ++ show n@@ -224,31 +227,36 @@     pblock i = map (expandParamsD False i id ns                       (concatMap tldeclared ps)) ps -elabDecl' what info (PNamespace n ps) = mapM_ (elabDecl' what ninfo) ps+elabDecl' what info (PNamespace n nfc ps) =+  do mapM_ (elabDecl' what ninfo) ps+     let ns = reverse (map T.pack newNS)+     sendHighlighting [(nfc, AnnNamespace ns Nothing)]   where-    ninfo = case namespace info of-                Nothing -> info { namespace = Just [n] }-                Just ns -> info { namespace = Just (n:ns) }-elabDecl' what info (PClass doc s f cs n ps pdocs fds ds)+    newNS = maybe [n] (n:) (namespace info)+    ninfo = info { namespace = Just newNS }++elabDecl' what info (PClass doc s f cs n nfc ps pdocs fds ds cn cd)   | what /= EDefns     = do iLOG $ "Elaborating class " ++ show n-         elabClass info (s { syn_params = [] }) doc f cs n ps pdocs fds ds-elabDecl' what info (PInstance doc argDocs s f cs n ps t expn ds)+         elabClass info (s { syn_params = [] }) doc f cs n nfc ps pdocs fds ds cn cd+elabDecl' what info (PInstance doc argDocs s f cs n nfc ps t expn ds)     = do iLOG $ "Elaborating instance " ++ show n-         elabInstance info s doc argDocs what f cs n ps t expn ds-elabDecl' what info (PRecord doc s f tyn ty opts cdoc cn cty)+         elabInstance info s doc argDocs what f cs n nfc ps t expn ds+elabDecl' what info (PRecord doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn)   | what /= ETypes-    = do iLOG $ "Elaborating record " ++ show tyn-         elabRecord info s doc f tyn ty opts cdoc cn cty+    = do iLOG $ "Elaborating record " ++ show name+         elabRecord info doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn+{-   | otherwise     = do iLOG $ "Elaborating [type of] " ++ show tyn          elabData info s doc [] f [] (PLaterdecl tyn ty)+-} elabDecl' _ info (PDSL n dsl)     = do i <- getIState          putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })          addIBC (IBCDSL n) elabDecl' what info (PDirective i)-  | what /= EDefns = i+  | what /= EDefns = directiveAction i elabDecl' what info (PProvider doc syn fc provWhat n)   | what /= EDefns     = do iLOG $ "Elaborating type provider " ++ show n
src/Idris/ElabQuasiquote.hs view
@@ -37,7 +37,7 @@ extractTUnquotes n (TCheck t) = extract1 n TCheck t extractTUnquotes n (TEval t) = extract1 n TEval t extractTUnquotes n (Claim name t) = extract1 n (Claim name) t-extractTUnquotes n tac = return (tac, []) -- the rest don't contain PTerms+extractTUnquotes n tac = return (tac, []) -- the rest don't contain PTerms, or have been desugared away  extractPArgUnquotes :: Int -> PArg -> Elab' aux (PArg, [(Name, PTerm)]) extractPArgUnquotes d (PImp p m opts n t) =@@ -58,32 +58,32 @@ extractDoUnquotes d (DoExp fc tm)   = do (tm', ex) <- extractUnquotes d tm        return (DoExp fc tm', ex)-extractDoUnquotes d (DoBind fc n tm)+extractDoUnquotes d (DoBind fc n nfc tm)   = do (tm', ex) <- extractUnquotes d tm-       return (DoBind fc n tm', ex)+       return (DoBind fc n nfc tm', ex) extractDoUnquotes d (DoBindP fc t t' alts)   = fail "Pattern-matching binds cannot be quasiquoted"-extractDoUnquotes d (DoLet  fc n v b)+extractDoUnquotes d (DoLet  fc n nfc v b)   = do (v', ex1) <- extractUnquotes d v        (b', ex2) <- extractUnquotes d b-       return (DoLet fc n v' b', ex1 ++ ex2)+       return (DoLet fc n nfc v' b', ex1 ++ ex2) extractDoUnquotes d (DoLetP fc t t') = fail "Pattern-matching lets cannot be quasiquoted"   extractUnquotes :: Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)])-extractUnquotes n (PLam fc name ty body)+extractUnquotes n (PLam fc name nfc ty body)   = do (ty', ex1) <- extractUnquotes n ty        (body', ex2) <- extractUnquotes n body-       return (PLam fc name ty' body', ex1 ++ ex2)-extractUnquotes n (PPi plicity name ty body)+       return (PLam fc name nfc ty' body', ex1 ++ ex2)+extractUnquotes n (PPi plicity name fc ty body)   = do (ty', ex1) <- extractUnquotes n ty        (body', ex2) <- extractUnquotes n body-       return (PPi plicity name ty' body', ex1 ++ ex2)-extractUnquotes n (PLet fc name ty val body)+       return (PPi plicity name fc ty' body', ex1 ++ ex2)+extractUnquotes n (PLet fc name nfc ty val body)   = do (ty', ex1) <- extractUnquotes n ty        (val', ex2) <- extractUnquotes n val        (body', ex3) <- extractUnquotes n body-       return (PLet fc name ty' val' body', ex1 ++ ex2 ++ ex3)+       return (PLet fc name nfc ty' val' body', ex1 ++ ex2 ++ ex3) extractUnquotes n (PTyped tm ty)   = do (tm', ex1) <- extractUnquotes n tm        (ty', ex2) <- extractUnquotes n ty@@ -104,15 +104,11 @@        (pats', exs1) <- fmap unzip $ mapM (extractUnquotes n) pats        (rhss', exs2) <- fmap unzip $ mapM (extractUnquotes n) rhss        return (PCase fc expr' (zip pats' rhss'), ex1 ++ concat exs1 ++ concat exs2)-extractUnquotes n (PRefl fc x)-  = do (x', ex) <- extractUnquotes n x-       return (PRefl fc x', ex)-extractUnquotes n (PEq fc at bt a b)-  = do (at', ex1) <- extractUnquotes n at-       (bt', ex2) <- extractUnquotes n bt-       (a', ex1) <- extractUnquotes n a-       (b', ex2) <- extractUnquotes n b-       return (PEq fc at' bt' a' b', ex1 ++ ex2)+extractUnquotes n (PIfThenElse fc c t f)+  = do (c', ex1) <- extractUnquotes n c+       (t', ex2) <- extractUnquotes n t+       (f', ex3) <- extractUnquotes n f+       return (PIfThenElse fc c' t' f', ex1 ++ ex2 ++ ex3) extractUnquotes n (PRewrite fc x y z)   = do (x', ex1) <- extractUnquotes n x        (y', ex2) <- extractUnquotes n y@@ -170,8 +166,8 @@                 return (PRef (fileFC "(unquote)") n, [(n, tm)])   | otherwise = fmap (\(tm', ex) -> (PUnquote tm', ex)) $                 extractUnquotes (n-1) tm-extractUnquotes n (PRunTactics fc tm)-  = fmap (\(tm', ex) -> (PRunTactics fc tm', ex)) $ extractUnquotes n tm+extractUnquotes n (PRunElab fc tm)+  = fmap (\(tm', ex) -> (PRunElab fc tm', ex)) $ extractUnquotes n tm extractUnquotes n x = return (x, []) -- no subterms!
− src/Idris/ElabTerm.hs 
@@ -1,2895 +0,0 @@-{-# LANGUAGE PatternGuards, ViewPatterns #-}-{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}-module Idris.ElabTerm where--import Idris.AbsSyntax-import Idris.AbsSyntaxTree-import Idris.DSL-import Idris.Delaborate-import Idris.Error-import Idris.ProofSearch-import Idris.Output (pshow)--import Idris.Core.Elaborate hiding (Tactic(..))-import Idris.Core.TT-import Idris.Core.Evaluate-import Idris.Core.Unify-import Idris.Core.Typecheck (check, recheck)-import Idris.ErrReverse (errReverse)-import Idris.ElabQuasiquote (extractUnquotes)-import Idris.Elab.Utils-import Idris.Reflection-import qualified Util.Pretty as U--import Control.Applicative ((<$>))-import Control.Monad-import Control.Monad.State.Strict-import Data.List-import qualified Data.Map as M-import Data.Maybe (mapMaybe, fromMaybe)-import qualified Data.Set as S-import qualified Data.Text as T-import Data.Vector.Unboxed (Vector)-import qualified Data.Vector.Unboxed as V--import Debug.Trace--data ElabMode = ETyDecl | ELHS | ERHS-  deriving Eq--data ElabResult =-  ElabResult { resultTerm :: Term -- ^ The term resulting from elaboration-             , resultMetavars :: [(Name, (Int, Maybe Name, Type))]-               -- ^ Information about new metavariables-             , resultCaseDecls :: [PDecl]-               -- ^ Deferred declarations as the meaning of case blocks-             , resultContext :: Context-               -- ^ The potentially extended context from new definitions-             , resultTyDecls :: [(Name, FC, [PArg], Type)]-               -- ^ Meta-info about the new type declarations-             }--processTacticDecls :: [(Name, FC, [PArg], Type)] -> Idris ()-processTacticDecls info =-  forM_ info $ \(n, fc, impls, ty) ->-    do logLvl 3 $ "Declaration from tactics: " ++ show n ++ " : " ++ show ty-       logLvl 3 $ "  It has impls " ++ show impls-       updateIState $ \i -> i { idris_implicits =-                                  addDef n impls (idris_implicits i) }-       addIBC (IBCImp n)-       ds <- checkDef fc iderr [(n, (-1, Nothing, ty))]-       addIBC (IBCDef n)-       let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds-       addDeferred ds'----- Using the elaborator, convert a term in raw syntax to a fully--- elaborated, typechecked term.------ If building a pattern match, we convert undeclared variables from--- holes to pattern bindings.---- Also find deferred names in the term and their types--build :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->-         ElabD ElabResult-build ist info emode opts fn tm-    = do elab ist info emode opts fn tm-         let tmIn = tm-         let inf = case lookupCtxt fn (idris_tyinfodata ist) of-                        [TIPartial] -> True-                        _ -> False--         when (not pattern) $ solveAutos ist fn True--         hs <- get_holes-         ivs <- get_instances-         ptm <- get_term-         -- Resolve remaining type classes. Two passes - first to get the-         -- default Num instances, second to clean up the rest-         when (not pattern) $-              mapM_ (\n -> when (n `elem` hs) $-                             do focus n-                                g <- goal-                                try (resolveTC True False 7 g fn ist)-                                    (movelast n)) ivs-         ivs <- get_instances-         hs <- get_holes-         when (not pattern) $-              mapM_ (\n -> when (n `elem` hs) $-                             do focus n-                                g <- goal-                                ptm <- get_term-                                resolveTC True True 7 g fn ist) ivs-         tm <- get_term-         ctxt <- get_context-         probs <- get_probs-         u <- getUnifyLog-         hs <- get_holes--         when (not pattern) $-           traceWhen u ("Remaining holes:\n" ++ show hs ++ "\n" ++-                        "Remaining problems:\n" ++ qshow probs) $-             do unify_all; matchProblems True; unifyProblems--         probs <- get_probs-         case probs of-            [] -> return ()-            ((_,_,_,_,e,_,_):es) -> traceWhen u ("Final problems:\n" ++ show probs) $-                                     if inf then return ()-                                            else lift (Error e)--         when tydecl (do update_term orderPats-                         mkPat)---                          update_term liftPats)-         EState is _ impls <- getAux-         tt <- get_term-         let (tm, ds) = runState (collectDeferred (Just fn) tt) []-         log <- getLog-         ctxt <- get_context-         if (log /= "") then trace log $ return (ElabResult tm ds is ctxt impls)-            else return (ElabResult tm ds is ctxt impls)-  where pattern = emode == ELHS-        tydecl = emode == ETyDecl--        mkPat = do hs <- get_holes-                   tm <- get_term-                   case hs of-                      (h: hs) -> do patvar h; mkPat-                      [] -> return ()---- Build a term autogenerated as a typeclass method definition--- (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 -> ElabMode -> FnOpts -> Name -> PTerm ->-         ElabD ElabResult-buildTC ist info emode opts fn tm-    = do -- set name supply to begin after highest index in tm-         let ns = allNamesIn tm-         let tmIn = tm-         let inf = case lookupCtxt fn (idris_tyinfodata ist) of-                        [TIPartial] -> True-                        _ -> False-         initNextNameFrom ns-         elab ist info emode opts fn tm-         probs <- get_probs-         tm <- get_term-         case probs of-            [] -> return ()-            ((_,_,_,_,e,_,_):es) -> if inf then return ()-                                           else lift (Error e)-         dots <- get_dotterm-         -- 'dots' are the PHidden things which have not been solved by-         -- unification-         when (not (null dots)) $-            lift (Error (CantMatch (getInferTerm tm)))-         EState is _ impls <- getAux-         tt <- get_term-         let (tm, ds) = runState (collectDeferred (Just fn) tt) []-         log <- getLog-         ctxt <- get_context-         if (log /= "") then trace log $ return (ElabResult tm ds is ctxt impls)-            else return (ElabResult tm ds is ctxt impls)-  where pattern = emode == ELHS---- return whether arguments of the given constructor name can be --- matched on. If they're polymorphic, no, unless the type has beed made--- concrete by the time we get around to elaborating the argument.-getUnmatchable :: Context -> Name -> [Bool]-getUnmatchable ctxt n | isDConName n ctxt && n /= inferCon-   = case lookupTyExact n ctxt of-          Nothing -> []-          Just ty -> checkArgs [] [] ty-  where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool]-        checkArgs env ns (Bind n (Pi _ t _) sc) -            = let env' = case t of-                              TType _ -> n : env-                              _ -> env in-                  checkArgs env' (intersect env (refsIn t) : ns) -                            (instantiate (P Bound n t) sc)-        checkArgs env ns t-            = map (not . null) (reverse ns)--getUnmatchable ctxt n = []--data ElabCtxt = ElabCtxt { e_inarg :: Bool,-                           e_isfn :: Bool, -- ^ Function part of application-                           e_guarded :: Bool, -                           e_intype :: Bool,-                           e_qq :: Bool,-                           e_nomatching :: Bool -- ^ can't pattern match-                         }--initElabCtxt = ElabCtxt False False False False False False--goal_polymorphic :: ElabD Bool-goal_polymorphic =-   do ty <- goal-      case ty of-           P _ n _ -> do env <- get_env-                         case lookup n env of-                              Nothing -> return False-                              _ -> return True-           _ -> return False---- | Returns the set of declarations we need to add to complete the--- definition (most likely case blocks to elaborate) as well as--- declarations resulting from user tactic scripts (%runTactics)-elab :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->-        ElabD ()-elab ist info emode opts fn tm-    = do let loglvl = opt_logLevel (idris_options ist)-         when (loglvl > 5) $ unifyLog True-         compute -- expand type synonyms, etc-         let fc = maybe "(unknown)"-         elabE initElabCtxt (elabFC info) tm -- (in argument, guarded, in type, in qquote)-         est <- getAux-         sequence_ (delayed_elab est)-         end_unify-         ptm <- get_term-         when pattern -- convert remaining holes to pattern vars-              (do update_term orderPats-                  unify_all-                  matchProblems False -- only the ones we matched earlier-                  unifyProblems-                  mkPat)-  where-    pattern = emode == ELHS-    bindfree = emode == ETyDecl || emode == ELHS--    tcgen = Dictionary `elem` opts-    reflection = Reflection `elem` opts--    isph arg = case getTm arg of-        Placeholder -> (True, priority arg)-        tm -> (False, priority arg)--    toElab ina arg = case getTm arg of-        Placeholder -> Nothing-        v -> Just (priority arg, elabE ina (elabFC info) v)--    toElab' ina arg = case getTm arg of-        Placeholder -> Nothing-        v -> Just (elabE ina (elabFC info) v)--    mkPat = do hs <- get_holes-               tm <- get_term-               case hs of-                  (h: hs) -> do patvar h; mkPat-                  [] -> return ()--    -- | elabE elaborates an expression, possibly wrapping implicit coercions-    -- and forces/delays.  If you make a recursive call in elab', it is-    -- normally correct to call elabE - the ones that don't are desugarings-    -- typically-    elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()-    elabE ina fc' t =-     --do g <- goal-        --trace ("Elaborating " ++ show t ++ " : " ++ show g) $-     do solved <- get_recents-        as <- get_autos-        -- If any of the autos use variables which have recently been solved,-        -- have another go at solving them now.-        mapM_ (\(a, ns) -> if any (\n -> n `elem` solved) ns-                              then solveAuto ist fn False a-                              else return ()) as-     -        itm <- if not pattern then insertImpLam ina t else return t-        ct <- insertCoerce ina itm-        t' <- insertLazy ct-        g <- goal-        tm <- get_term-        ps <- get_probs-        hs <- get_holes--        --trace ("Elaborating " ++ show t' ++ " in " ++ show g-        --         ++ "\n" ++ show tm-        --         ++ "\nholes " ++ show hs-        --         ++ "\nproblems " ++ show ps-        --         ++ "\n-----------\n") $-        --trace ("ELAB " ++ show t') $-        let fc = fileFC "Force"-        env <- get_env-        handleError (forceErr env)-            (elab' ina fc' t')-            (elab' ina fc' (PApp fc (PRef fc (sUN "Force"))-                             [pimp (sUN "t") Placeholder True,-                              pimp (sUN "a") Placeholder True,-                              pexp ct])) True--    forceErr env (CantUnify _ (t,_) (t',_) _ _ _)-       | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),-            ht == txt "Lazy'" = True-    forceErr env (CantUnify _ (t,_) (t',_) _ _ _)-       | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t'),-            ht == txt "Lazy'" = True-    forceErr env (InfiniteUnify _ t _)-       | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),-            ht == txt "Lazy'" = True-    forceErr env (Elaborating _ _ t) = forceErr env t-    forceErr env (ElaboratingArg _ _ _ t) = forceErr env t-    forceErr env (At _ t) = forceErr env t-    forceErr env t = False--    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--    -- "guarded" means immediately under a constructor, to help find patvars--    elab' :: ElabCtxt  -- ^ (in an argument, guarded, in a type, in a quasiquote)-          -> Maybe FC -- ^ The closest FC in the syntax tree, if applicable-          -> PTerm -- ^ The term to elaborate-          -> ElabD ()-    elab' ina fc (PNoImplicits t) = elab' ina fc t -- skip elabE step-    elab' ina fc PType           = do apply RType []; solve-    elab' ina fc (PUniverse u)   = do apply (RUType u) []; solve---  elab' (_,_,inty) (PConstant c)---     | constType c && pattern && not reflection && not inty---       = lift $ tfail (Msg "Typecase is not allowed")-    elab' ina fc tm@(PConstant c) -         | pattern && not reflection && not (e_qq ina) && not (e_intype ina)-           && isTypeConst c-              = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)-         | pattern && not reflection && not (e_qq ina) && e_nomatching ina-              = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)-         | otherwise = do apply (RConstant c) []; solve-    elab' ina fc (PQuote r)     = do fill r; solve-    elab' ina _ (PTrue fc _)   =-       do hnf_compute-          g <- goal-          case g of-            TType _ -> elab' ina (Just fc) (PRef fc unitTy)-            UType _ -> elab' ina (Just fc) (PRef fc unitTy)-            _ -> elab' ina (Just fc) (PRef fc unitCon)-    elab' ina fc (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes-       = do g <- goal; resolveTC False False 5 g fn ist-    elab' ina fc (PResolveTC fc')-        = do c <- getNameFrom (sMN 0 "class")-             instanceArg c-    elab' ina _ (PRefl fc t)-        = elab' ina (Just fc) (PApp fc (PRef fc eqCon) [pimp (sMN 0 "A") Placeholder True,-                                                   pimp (sMN 0 "x") t False])-    elab' ina _ (PEq fc Placeholder Placeholder l r)-       = try (do tyn <- getNameFrom (sMN 0 "aqty")-                 claim tyn RType-                 movelast tyn-                 elab' ina (Just fc) (PApp fc (PRef fc eqTy)-                              [pimp (sUN "A") (PRef fc tyn) True,-                               pimp (sUN "B") (PRef fc tyn) False,-                               pexp l, pexp r]))-             (do atyn <- getNameFrom (sMN 0 "aqty")-                 btyn <- getNameFrom (sMN 0 "bqty")-                 claim atyn RType-                 movelast atyn-                 claim btyn RType-                 movelast btyn-                 elab' ina (Just fc) (PApp fc (PRef fc eqTy)-                   [pimp (sUN "A") (PRef fc atyn) True,-                    pimp (sUN "B") (PRef fc btyn) False,-                    pexp l, pexp r]))--    elab' ina _ (PEq fc lt rt l r) = elab' ina (Just fc) (PApp fc (PRef fc eqTy)-                                       [pimp (sUN "A") lt True,-                                        pimp (sUN "B") rt False,-                                        pexp l, pexp r])-    elab' ina _ (PPair fc _ l r)-        = do hnf_compute-             g <- goal-             let (tc, _) = unApply g-             case g of-                TType _ -> elab' ina (Just fc) (PApp fc (PRef fc pairTy)-                                                      [pexp l,pexp r])-                UType _ -> elab' ina (Just fc) (PApp fc (PRef fc upairTy)-                                                      [pexp l,pexp r])-                _ -> case tc of-                        P _ n _ | n == upairTy -                          -> elab' ina (Just fc) (PApp fc (PRef fc upairCon)-                                                [pimp (sUN "A") Placeholder False,-                                                 pimp (sUN "B") Placeholder False,-                                                 pexp l, pexp r])-                        _ -> elab' ina (Just fc) (PApp fc (PRef fc pairCon)-                                                [pimp (sUN "A") Placeholder False,-                                                 pimp (sUN "B") Placeholder False,-                                                 pexp l, pexp r])---                         _ -> try' (elab' ina (Just fc) (PApp fc (PRef fc pairCon)---                                                 [pimp (sUN "A") Placeholder False,---                                                  pimp (sUN "B") Placeholder False,---                                                  pexp l, pexp r]))---                                   (elab' ina (Just fc) (PApp fc (PRef fc upairCon)---                                                 [pimp (sUN "A") Placeholder False,---                                                  pimp (sUN "B") Placeholder False,---                                                  pexp l, pexp r]))---                                   True--    elab' ina _ (PDPair fc p l@(PRef _ n) t r)-            = case t of-                Placeholder ->-                   do hnf_compute-                      g <- goal-                      case g of-                         TType _ -> asType-                         _ -> asValue-                _ -> asType-         where asType = elab' ina (Just fc) (PApp fc (PRef fc sigmaTy)-                                        [pexp t,-                                         pexp (PLam fc n Placeholder r)])-               asValue = elab' ina (Just fc) (PApp fc (PRef fc existsCon)-                                         [pimp (sMN 0 "a") t False,-                                          pimp (sMN 0 "P") Placeholder True,-                                          pexp l, pexp r])-    elab' ina _ (PDPair fc p l t r) = elab' ina (Just fc) (PApp fc (PRef fc existsCon)-                                              [pimp (sMN 0 "a") t False,-                                               pimp (sMN 0 "P") Placeholder True,-                                               pexp l, pexp r])-    elab' ina fc (PAlternative True as)-        = do hnf_compute-             ty <- goal-             ctxt <- get_context-             let (tc, _) = unApply ty-             env <- get_env-             let as' = pruneByType (map fst env) tc ctxt as---              trace (-- show tc ++ " " ++ show as ++ "\n ==> " ++ ---                     show (length as') ++ "\n" ++---                     showSep ", " (map showTmImpls as') ++ "\nEND") $-             tryAll (zip (map (elab' ina fc) as') (map showHd as'))-        where showHd (PApp _ (PRef _ n) _) = n-              showHd (PRef _ n) = n-              showHd (PApp _ h _) = showHd h-              showHd x = NErased -- We probably should do something better than this here-    elab' ina fc (PAlternative False as)-        = trySeq as-        where -- if none work, take the error from the first-              trySeq (x : xs) = let e1 = elab' ina fc x in-                                    try' e1 (trySeq' e1 xs) True-              trySeq [] = fail "Nothing to try in sequence"-              trySeq' deferr [] = proofFail deferr-              trySeq' deferr (x : xs)-                  = try' (do elab' ina fc x-                             solveAutos ist fn False) (trySeq' deferr xs) True-    elab' ina _ (PPatvar fc n) | bindfree = do patvar n; update_term liftPats---    elab' (_, _, inty) (PRef fc f)---       | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty---          = lift $ tfail (Msg "Typecase is not allowed")-    elab' ec _ tm@(PRef fc n)-      | pattern && not reflection && not (e_qq ec) && not (e_intype ec)-            && isTConName n (tt_ctxt ist)-              = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)-      | pattern && not reflection && not (e_qq ec) && e_nomatching ec-              = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)-      | (pattern || (bindfree && bindable n)) && not (inparamBlock n) && not (e_qq ec)-        = do let ina = e_inarg ec-                 guarded = e_guarded ec-                 inty = e_intype ec-             ctxt <- get_context-             let defined = case lookupTy n ctxt of-                               [] -> False-                               _ -> True-           -- this is to stop us resolve type classes recursively-             -- trace (show (n, guarded)) $-             if (tcname n && ina) then erun fc $ do patvar n; -- update_term liftPats-               else if (defined && not guarded)-                       then do apply (Var n) []; solve-                       else try (do apply (Var n) []; solve)-                                (do patvar n; update_term liftPats)-      where inparamBlock n = case lookupCtxtName n (inblock info) of-                                [] -> False-                                _ -> True-            bindable (NS _ _) = False-            bindable (UN xs) = True-            bindable n = implicitable n-    elab' ina _ f@(PInferRef fc n) = elab' ina (Just fc) (PApp fc f [])-    elab' ina fc' tm@(PRef fc n) -          | pattern && not reflection && not (e_qq ina) && not (e_intype ina)-            && isTConName n (tt_ctxt ist)-              = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)-          | pattern && not reflection && not (e_qq ina) && e_nomatching ina-              = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)-          | otherwise = -               do fty <- get_type (Var n) -- check for implicits-                  ctxt <- get_context-                  env <- get_env -                  let a' = insertScopedImps fc (normalise ctxt env fty) []-                  if null a'-                     then erun fc $ do apply (Var n) []; solve-                     else elab' ina fc' (PApp fc tm [])-    elab' ina _ (PLam fc 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 (ina { e_inarg = True } ) (Just fc) sc; solve-    elab' ec _ (PLam fc 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-               introTy (Var tyn) (Just n)-               focus tyn-               -               elabE (ec { e_inarg = True, e_intype = True }) (Just fc) ty-               elabE (ec { e_inarg = True }) (Just fc) sc-               solve-    elab' ina fc (PPi p n Placeholder sc)-          = do attack; arg n (is_scoped p) (sMN 0 "ty") -               elabE (ina { e_inarg = True, e_intype = True }) fc sc-               solve-    elab' ina fc (PPi p 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' (is_scoped p) (Var tyn)-               focus tyn-               let ec' = ina { e_inarg = True, e_intype = True }-               elabE ec' fc ty-               elabE ec' fc sc-               solve-    elab' ina _ (PLet fc n ty val sc)-          = do attack-               ivs <- get_instances-               tyn <- getNameFrom (sMN 0 "letty")-               claim tyn RType-               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-                           explicit tyn-                           elabE (ina { e_inarg = True, e_intype = True }) -                                 (Just fc) ty-               focus valn-               elabE (ina { e_inarg = True, e_intype = True }) -                     (Just fc) val-               ivs' <- get_instances-               env <- get_env-               elabE (ina { e_inarg = True }) (Just fc) sc-               when (not pattern) $-                   mapM_ (\n -> do focus n-                                   g <- goal-                                   hs <- get_holes-                                   if all (\n -> n == tyn || not (n `elem` hs)) (freeNames g)-                                    then try (resolveTC True False 7 g fn ist)-                                             (movelast n)-                                    else movelast n)-                         (ivs' \\ ivs)-               -- 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-                                 other -> error ("Value not a let binding: " ++ show other))-               solve-    elab' ina _ (PGoal fc r n sc) = do-         rty <- goal-         attack-         tyn <- getNameFrom (sMN 0 "letty")-         claim tyn RType-         valn <- getNameFrom (sMN 0 "letval")-         claim valn (Var tyn)-         letbind n (Var tyn) (Var valn)-         focus valn-         elabE (ina { e_inarg = True, e_intype = True }) (Just fc) (PApp fc r [pexp (delab ist rty)])-         env <- get_env-         computeLet n-         elabE (ina { e_inarg = True }) (Just fc) sc-         solve---          elab' ina fc (PLet n Placeholder---              (PApp fc r [pexp (delab ist rty)]) sc)-    elab' ina _ tm@(PApp fc (PInferRef _ f) args) = do-         rty <- goal-         ds <- get_deferred-         ctxt <- get_context-         -- make a function type a -> b -> c -> ... -> rty for the-         -- new function name-         env <- get_env-         argTys <- claimArgTys env args-         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-         attack; deferType (mkN f) fty (map fst argTys); solve-         -- elaborate the arguments, to unify their types. They all have to-         -- be explicit.-         mapM_ elabIArg (zip argTys args)-       where claimArgTys env [] = return []-             claimArgTys env (arg : xs) | Just n <- localVar env (getTm arg)-                                  = do nty <- get_type (Var n)-                                       ans <- claimArgTys env xs-                                       return ((n, (False, forget nty)) : ans)-             claimArgTys env (_ : xs)-                                  = do an <- getNameFrom (sMN 0 "inf_argTy")-                                       aval <- getNameFrom (sMN 0 "inf_arg")-                                       claim an RType-                                       claim aval (Var an)-                                       ans <- claimArgTys env xs-                                       return ((aval, (True, (Var an))) : ans)-             fnTy [] ret  = forget ret-             fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi Nothing xt RType) (fnTy xs ret)--             localVar env (PRef _ x)-                           = case lookup x env of-                                  Just _ -> Just x-                                  _ -> Nothing-             localVar env _ = Nothing--             elabIArg ((n, (True, ty)), def) =-               do focus n; elabE ina (Just fc) (getTm def)-             elabIArg _ = return () -- already done, just a name--             mkN n@(NS _ _) = n-             mkN n@(SN _) = n-             mkN n = case namespace info of-                        Just xs@(_:_) -> sNS n xs-                        _ -> n--    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-    -- if f is local, just do a simple_app-    -- FIXME: Anyone feel like refactoring this mess? - EB-    elab' ina topfc tm@(PApp fc (PRef _ f) args_in)-      | pattern && not reflection && not (e_qq ina) && e_nomatching ina-              = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)-      | otherwise = implicitApp $-         do env <- get_env-            ty <- goal-            fty <- get_type (Var f)-            ctxt <- get_context-            let args = insertScopedImps fc (normalise ctxt env fty) args_in-            let unmatchableArgs = if pattern -                                     then getUnmatchable (tt_ctxt ist) f-                                     else []---             trace ("BEFORE " ++ show f ++ ": " ++ show ty) $ -            when (pattern && not reflection && not (e_qq ina) && not (e_intype ina)-                          && isTConName f (tt_ctxt ist)) $-              lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)-            if (f `elem` map fst env && length args == 1 && length args_in == 1)-               then -- simple app, as below-                    do simple_app False -                                  (elabE (ina { e_isfn = True }) (Just fc) (PRef fc f))-                                  (elabE (ina { e_inarg = True }) (Just fc) (getTm (head args)))-                                  (show tm)-                       solve-                       return []-               else-                 do ivs <- get_instances-                    ps <- get_probs-                    -- HACK: we shouldn't resolve type classes if we're defining an instance-                    -- function or default definition.-                    let isinf = f == inferCon || tcname f-                    -- if f is a type class, we need to know its arguments so that-                    -- we can unify with them-                    case lookupCtxt f (idris_classes ist) of-                        [] -> return ()-                        _ -> do mapM_ setInjective (map getTm args)-                                -- maybe more things are solvable now-                                unifyProblems-                    let guarded = isConName f ctxt---                    trace ("args is " ++ show args) $ return ()-                    ns <- apply (Var f) (map isph args)---                    trace ("ns is " ++ show ns) $ return ()-                    -- mark any type class arguments as injective-                    mapM_ checkIfInjective (map snd ns)-                    unifyProblems -- try again with the new information,-                                  -- to help with disambiguation-                    -- Sort so that the implicit tactics and alternatives go last-                    let (ns', eargs) = unzip $-                             sortBy cmpArg (zip ns args)-                    ulog <- getUnifyLog-                    elabArgs ist (ina { e_inarg = e_inarg ina || not isinf }) -                           [] fc False f -                             (zip ns' (unmatchableArgs ++ repeat False))-                             (f == sUN "Force")-                             (map (\x -> getTm x) eargs) -- TODO: remove this False arg-                    imp <- if (e_isfn ina) then-                              do guess <- get_guess-                                 gty <- get_type (forget guess)-                                 env <- get_env-                                 let ty_n = normalise ctxt env gty-                                 return $ getReqImps ty_n-                              else return []-                    -- Now we find out how many implicits we needed at the-                    -- end of the application by looking at the goal again-                    -- - Have another go, but this time add the-                    -- implicits (can't think of a better way than this...)-                    case imp of-                         rs@(_:_) | not pattern -> return rs -- quit, try again-                         _ -> do solve-                                 hs <- get_holes-                                 ivs' <- get_instances-                                 -- Attempt to resolve any type classes which have 'complete' types,-                                 -- i.e. no holes in them-                                 when (not pattern || (e_inarg ina && not tcgen && -                                                      not (e_guarded ina))) $-                                    mapM_ (\n -> do focus n-                                                    g <- goal-                                                    env <- get_env-                                                    hs <- get_holes-                                                    if all (\n -> not (n `elem` hs)) (freeNames g)-                                                     then try (resolveTC False False 7 g fn ist)-                                                              (movelast n)-                                                     else movelast n)-                                          (ivs' \\ ivs)-                                 return []-      where -            -- Run the elaborator, which returns how many implicit-            -- args were needed, then run it again with those args. We need-            -- this because we have to elaborate the whole application to-            -- find out whether any computations have caused more implicits-            -- to be needed.-            implicitApp :: ElabD [ImplicitInfo] -> ElabD ()-            implicitApp elab -              | pattern = do elab; return ()-              | otherwise-                = do s <- get-                     imps <- elab-                     case imps of-                          [] -> return ()-                          es -> do put s-                                   elab' ina topfc (PAppImpl tm es)-    -            getReqImps (Bind x (Pi (Just i) ty _) sc)-                 = i : getReqImps sc-            getReqImps _ = []--            -- normal < alternatives < lambdas < rewrites < tactic < default tactic-            -- reason for lambdas after alternatives is that having-            -- the alternative resolved can help with typechecking the lambda-            -- or the rewrite. Rewrites/tactics need as much information-            -- as possible about the type.-            -- FIXME: Better would be to allow alternative resolution to be-            -- retried after more information is in.-            cmpArg (_, x) (_, y)-                | constraint x && not (constraint y) = LT-                | constraint y && not (constraint x) = GT-                | otherwise-                   = compare (conDepth 0 (getTm x) + priority x + alt x)-                             (conDepth 0 (getTm y) + priority y + alt y)-                where alt t = case getTm t of-                                   PAlternative False _ -> 5-                                   PAlternative True _ -> 2-                                   PTactics _ -> 150-                                   PLam _ _ _ _ -> 3-                                   PRewrite _ _ _ _ -> 4-                                   PResolveTC _ -> 0-                                   PHidden _ -> 150-                                   _ -> 1--            constraint (PConstraint _ _ _ _) = True-            constraint _ = False--            -- Score a point for every level where there is a non-constructor-            -- function (so higher score --> done later), and lots of points-            -- if there is a PHidden since this should be unifiable.-            -- Only relevant when on lhs-            conDepth d t | not pattern = 0-            conDepth d (PRef _ f) | isConName f (tt_ctxt ist) = 0-                                  | otherwise = max (100 - d) 1-            conDepth d (PApp _ f as)-               = conDepth d f + sum (map (conDepth (d+1)) (map getTm as))-            conDepth d (PPatvar _ _) = 0-            conDepth d (PAlternative _ as) = maximum (map (conDepth d) as)-            conDepth d (PHidden _) = 150-            conDepth d Placeholder = 0-            conDepth d (PResolveTC _) = 0-            conDepth d t = max (100 - d) 1--            checkIfInjective n = do-                env <- get_env-                case lookup n env of-                     Nothing -> return ()-                     Just b ->-                       case unApply (binderTy b) of-                            (P _ c _, args) ->-                                case lookupCtxtExact c (idris_classes ist) of-                                   Nothing -> return ()-                                   Just ci -> -- type class, set as injective-                                        do mapM_ setinjArg (getDets 0 (class_determiners ci) args)-                                        -- maybe we can solve more things now...-                                           ulog <- getUnifyLog-                                           probs <- get_probs-                                           traceWhen ulog ("Injective now " ++ show args ++ "\n" ++ qshow probs) $-                                             unifyProblems-                                           probs <- get_probs-                                           traceWhen ulog (qshow probs) $ return ()-                            _ -> return ()--            setinjArg (P _ n _) = setinj n-            setinjArg _ = return ()--            getDets i ds [] = []-            getDets i ds (a : as) | i `elem` ds = a : getDets (i + 1) ds as-                                  | otherwise = getDets (i + 1) ds as--            tacTm (PTactics _) = True-            tacTm (PProof _) = True-            tacTm _ = False--            setInjective (PRef _ n) = setinj n-            setInjective (PApp _ (PRef _ n) _) = setinj n-            setInjective _ = return ()--    elab' ina _ tm@(PApp fc f [arg]) = -            erun fc $-             do simple_app (not $ headRef f)-                           (elabE (ina { e_isfn = True }) (Just fc) f) -                           (elabE (ina { e_inarg = True }) (Just fc) (getTm arg))-                                (show tm)-                solve-        where headRef (PRef _ _) = True-              headRef (PApp _ f _) = headRef f-              headRef _ = False--    elab' ina fc (PAppImpl f es) = do appImpl (reverse es) -- not that we look... -                                      solve-        where appImpl [] = elab' (ina { e_isfn = False }) fc f -- e_isfn not set, so no recursive expansion of implicits-              appImpl (e : es) = simple_app False-                                            (appImpl es)-                                            (elab' ina fc Placeholder)-                                            (show f)-    elab' ina fc Placeholder -        = do (h : hs) <- get_holes-             movelast h-    elab' ina fc (PMetavar n) =-          do ptm <- get_term-             -- When building the metavar application, leave out the unique-             -- names which have been used elsewhere in the term, since we-             -- won't be able to use them in the resulting application.-             let unique_used = getUniqueUsed (tt_ctxt ist) ptm-             let n' = mkN n-             attack-             defer unique_used n'-             solve-        where mkN n@(NS _ _) = n-              mkN n = case namespace info of-                        Just xs@(_:_) -> sNS n xs-                        _ -> n-    elab' ina fc (PProof ts) = do compute; mapM_ (runTac True ist (elabFC info) fn) ts-    elab' ina fc (PTactics ts)-        | not pattern = do mapM_ (runTac False ist fc fn) ts-        | otherwise = elab' ina fc Placeholder-    elab' ina fc (PElabError e) = lift $ tfail e-    elab' ina _ (PRewrite fc r sc newg)-        = do attack-             tyn <- getNameFrom (sMN 0 "rty")-             claim tyn RType-             valn <- getNameFrom (sMN 0 "rval")-             claim valn (Var tyn)-             letn <- getNameFrom (sMN 0 "_rewrite_rule")-             letbind letn (Var tyn) (Var valn)-             focus valn-             elab' ina (Just fc) r-             compute-             g <- goal-             rewrite (Var letn)-             g' <- goal-             when (g == g') $ lift $ tfail (NoRewriting g)-             case newg of-                 Nothing -> elab' ina (Just fc) sc-                 Just t -> doEquiv t sc-             solve-        where doEquiv t sc =-                do attack-                   tyn <- getNameFrom (sMN 0 "ety")-                   claim tyn RType-                   valn <- getNameFrom (sMN 0 "eqval")-                   claim valn (Var tyn)-                   letn <- getNameFrom (sMN 0 "equiv_val")-                   letbind letn (Var tyn) (Var valn)-                   focus tyn-                   elab' ina (Just fc) t-                   focus valn-                   elab' ina (Just fc) sc-                   elab' ina (Just fc) (PRef fc letn)-                   solve-    elab' ina _ c@(PCase fc scr opts)-        = do attack-             tyn <- getNameFrom (sMN 0 "scty")-             claim tyn RType-             valn <- getNameFrom (sMN 0 "scval")-             scvn <- getNameFrom (sMN 0 "scvar")-             claim valn (Var tyn)-             letbind scvn (Var tyn) (Var valn)-             focus valn-             elabE (ina { e_inarg = True }) (Just fc) scr-             -- Solve any remaining implicits - we need to solve as many-             -- as possible before making the 'case' type-             unifyProblems-             matchProblems True-             args <- get_env-             envU <- mapM (getKind args) args-             let namesUsedInRHS = nub $ scvn : concatMap (\(_,rhs) -> allNamesIn rhs) opts--             -- Drop the unique arguments used in the term already-             -- and in the scrutinee (since it's-             -- not valid to use them again anyway) -             ---             -- Also drop unique arguments which don't appear explicitly-             -- in either case branch so they don't count as used-             -- unnecessarily (can only do this for unique things, since we-             -- assume they don't appear implicitly in types)-             ptm <- get_term-             let inOpts = (filter (/= scvn) (map fst args)) \\ (concatMap (\x -> allNamesIn (snd x)) opts)--             let argsDropped = filter (isUnique envU) -                                   (nub $ allNamesIn scr ++ inApp ptm ++-                                    inOpts)--             let args' = filter (\(n, _) -> n `notElem` argsDropped) args--             cname <- unique_hole' True (mkCaseName fn)-             let cname' = mkN cname---              elab' ina fc (PMetavar cname')-             attack; defer argsDropped cname'; solve--             -- if the scrutinee is one of the 'args' in env, we should-             -- inspect it directly, rather than adding it as a new argument-             let newdef = PClauses fc [] cname'-                             (caseBlock fc cname'-                                (map (isScr scr) (reverse args')) opts)-             -- elaborate case-             updateAux (\e -> e { case_decls = newdef : case_decls e } )-             -- if we haven't got the type yet, hopefully we'll get it later!-             movelast tyn-             solve-        where mkCaseName (NS n ns) = NS (mkCaseName n) ns-              mkCaseName n = SN (CaseN n)---               mkCaseName (UN x) = UN (x ++ "_case")---               mkCaseName (MN i x) = MN i (x ++ "_case")-              mkN n@(NS _ _) = n-              mkN n = case namespace info of-                        Just xs@(_:_) -> sNS n xs-                        _ -> n--              inApp (P _ n _) = [n]-              inApp (App f a) = inApp f ++ inApp a-              inApp (Bind n (Let _ v) sc) = inApp v ++ inApp sc-              inApp (Bind n (Guess _ v) sc) = inApp v ++ inApp sc-              inApp (Bind n b sc) = inApp sc-              inApp _ = []--              isUnique envk n = case lookup n envk of-                                     Just u -> u-                                     _ -> False--              getKind env (n, _)-                  = case lookup n env of-                         Nothing -> return (n, False) -- can't happen, actually...-                         Just b ->-                            do ty <- get_type (forget (binderTy b))-                               case ty of-                                    UType UniqueType -> return (n, True)-                                    UType AllTypes -> return (n, True)-                                    _ -> return (n, False)--              tcName tm | (P _ n _, _) <- unApply tm-                  = case lookupCtxt n (idris_classes ist) of-                         [_] -> True-                         _ -> False-              tcName _ = False--              usedIn ns (n, b)-                 = n `elem` ns-                     || any (\x -> x `elem` ns) (allTTNames (binderTy b))--    elab' ina fc (PUnifyLog t) = do unifyLog True-                                    elab' ina fc t-                                    unifyLog False-    elab' ina fc (PQuasiquote t goalt)-        = do -- First extract the unquoted subterms, replacing them with fresh-             -- names in the quasiquoted term. Claim their reflections to be-             -- an inferred type (to support polytypic quasiquotes).-             finalTy <- goal-             (t, unq) <- extractUnquotes 0 t-             let unquoteNames = map fst unq-             mapM_ (\uqn -> claim uqn (forget finalTy)) unquoteNames--             -- Save the old state - we need a fresh proof state to avoid-             -- capturing lexically available variables in the quoted term.-             ctxt <- get_context-             saveState-             updatePS (const .-                       newProof (sMN 0 "q") ctxt $-                       P Ref (reflm "TT") Erased)--             -- Re-add the unquotes, letting Idris infer the (fictional)-             -- types. Here, they represent the real type rather than the type-             -- of their reflection.-             mapM_ (\n -> do ty <- getNameFrom (sMN 0 "unqTy")-                             claim ty RType-                             movelast ty-                             claim n (Var ty)-                             movelast n)-                   unquoteNames--             -- Determine whether there's an explicit goal type, and act accordingly-             -- Establish holes for the type and value of the term to be-             -- quasiquoted-             qTy <- getNameFrom (sMN 0 "qquoteTy")-             claim qTy RType-             movelast qTy-             qTm <- getNameFrom (sMN 0 "qquoteTm")-             claim qTm (Var qTy)--             -- Let-bind the result of elaborating the contained term, so that-             -- the hole doesn't disappear-             nTm <- getNameFrom (sMN 0 "quotedTerm")-             letbind nTm (Var qTy) (Var qTm)--             -- Fill out the goal type, if relevant-             case goalt of-               Nothing  -> return ()-               Just gTy -> do focus qTy-                              elabE (ina { e_qq = True }) fc gTy--             -- Elaborate the quasiquoted term into the hole-             focus qTm-             elabE (ina { e_qq = True }) fc t-             end_unify--             -- We now have an elaborated term. Reflect it and solve the-             -- original goal in the original proof state.-             env <- get_env-             loadState-             let quoted = fmap (explicitNames . binderVal) $ lookup nTm env-                 isRaw = case unApply (normaliseAll ctxt env finalTy) of-                           (P _ n _, []) | n == reflm "Raw" -> True-                           _ -> False-             case quoted of-               Just q -> do ctxt <- get_context-                            (q', _, _) <- lift $ recheck ctxt [(uq, Lam Erased) | uq <- unquoteNames] (forget q) q-                            if pattern-                              then if isRaw-                                      then reflectRawQuotePattern unquoteNames (forget q')-                                      else reflectTTQuotePattern unquoteNames q'-                              else do if isRaw-                                        then -- we forget q' instead of using q to ensure rechecking-                                             fill $ reflectRawQuote unquoteNames (forget q')-                                        else fill $ reflectTTQuote unquoteNames q'-                                      solve--               Nothing -> lift . tfail . Msg $ "Broken elaboration of quasiquote"--             -- Finally fill in the terms or patterns from the unquotes. This-             -- happens last so that their holes still exist while elaborating-             -- the main quotation.-             mapM_ elabUnquote unq-      where elabUnquote (n, tm)-                = do focus n-                     elabE (ina { e_qq = False }) fc tm---    elab' ina fc (PUnquote t) = fail "Found unquote outside of quasiquote"-    elab' ina fc (PAs _ n t) = lift . tfail . Msg $ "@-pattern not allowed here"-    elab' ina fc (PHidden t) -      | reflection = elab' ina fc t-      | otherwise-        = do (h : hs) <- get_holes-             -- Dotting a hole means that either the hole or any outer-             -- hole (a hole outside any occurrence of it) -             -- must be solvable by unification as well as being filled-             -- in directly.-             -- Delay dotted things to the end, then when we elaborate them-             -- we can check the result against what was inferred-             movelast h-             delayElab $ do focus h-                            dotterm-                            elab' ina fc t-    elab' ina fc (PRunTactics fc' tm) =-      do attack-         n <- getNameFrom (sMN 0 "tacticScript")-         n' <- getNameFrom (sMN 0 "tacticExpr")-         let scriptTy = RApp (Var (sNS (sUN "Tactical") ["Tactical", "Reflection", "Language"])) (Var unitTy)-         claim n scriptTy-         movelast n-         letbind n' scriptTy (Var n)-         focus n-         elab' ina (Just fc') tm-         env <- get_env-         runTactical (maybe fc' id fc) env (P Bound n' Erased)-         EState _ _ todo <- getAux-         solve-    elab' ina fc x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x--    delayElab t = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [t] }) --    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' = findScr env-              args = map mkarg (map getNmScr args') in-              map (mkClause args) opts--       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!-             findScr [] = error "The impossible happened - the scrutinee was not 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 (mkLHSarg l) args') in-                            PClause (getFC fc l) n lhs [] r []--             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-    getFC d (PRef fc _) = fc-    getFC d (PAlternative _ (x:_)) = getFC d x-    getFC d x = d--    insertLazy :: PTerm -> ElabD PTerm-    insertLazy t@(PApp _ (PRef _ (UN l)) _) | l == txt "Delay" = return t-    insertLazy t@(PApp _ (PRef _ (UN l)) _) | l == txt "Force" = return t-    insertLazy (PCoerced t) = return t-    insertLazy t =-        do ty <- goal-           env <- get_env-           let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)-           let tries = if pattern then [t, mkDelay env t] else [mkDelay env t, t]-           case tyh of-                P _ (UN l) _ | l == txt "Lazy'"-                    -> return (PAlternative False tries)-                _ -> return t-      where-        mkDelay env (PAlternative b xs) = PAlternative b (map (mkDelay env) xs)-        mkDelay env t-            = let fc = fileFC "Delay" in-                  addImplBound ist (map fst env) (PApp fc (PRef fc (sUN "Delay"))-                                                 [pexp t])---    -- Don't put implicit coercions around applications which are marked-    -- as '%noImplicit', or around case blocks, otherwise we get exponential-    -- blowup especially where there are errors deep in large expressions.-    notImplicitable (PApp _ f _) = notImplicitable f-    -- TMP HACK no coercing on bind (make this configurable)-    notImplicitable (PRef _ n)-        | [opts] <- lookupCtxt n (idris_flags ist)-            = NoImplicit `elem` opts-    notImplicitable (PAlternative True as) = any notImplicitable as-    -- case is tricky enough without implicit coercions! If they are needed,-    -- they can go in the branches separately.-    notImplicitable (PCase _ _ _) = True-    notImplicitable _ = False--    insertScopedImps fc (Bind n (Pi im@(Just i) _ _) sc) xs-      | tcinstance i-          = pimp n (PResolveTC fc) True : insertScopedImps fc sc xs-      | otherwise-          = pimp n Placeholder True : insertScopedImps fc sc xs-    insertScopedImps fc (Bind n (Pi _ _ _) sc) (x : xs)-        = x : insertScopedImps fc sc xs-    insertScopedImps _ _ xs = xs--    insertImpLam ina t =-        do ty <- goal-           env <- get_env-           let ty' = normalise (tt_ctxt ist) env ty-           addLam ty' t-      where-        -- just one level at a time-        addLam (Bind n (Pi (Just _) _ _) sc) t =-                 do impn <- unique_hole (sMN 0 "imp")-                    if e_isfn ina -- apply to an implicit immediately-                       then return (PApp emptyFC-                                         (PLam emptyFC impn Placeholder t)-                                         [pexp Placeholder])-                       else return (PLam emptyFC impn Placeholder t)-        addLam _ t = return t--    insertCoerce ina t@(PCase _ _ _) = return t-    insertCoerce ina t | notImplicitable t = return t-    insertCoerce ina t =-        do ty <- goal-           -- Check for possible coercions to get to the goal-           -- and add them as 'alternatives'-           env <- get_env-           let ty' = normalise (tt_ctxt ist) env ty-           let cs = getCoercionsTo ist ty'-           let t' = case (t, cs) of-                         (PCoerced tm, _) -> tm-                         (_, []) -> t-                         (_, cs) -> PAlternative False [t ,-                                       PAlternative True (map (mkCoerce env t) cs)]-           return t'-       where-         mkCoerce env t n = let fc = maybe (fileFC "Coercion") id (highestFC t) in-                                addImplBound ist (map fst env)-                                  (PApp fc (PRef fc n) [pexp (PCoerced t)])--    -- | Elaborate the arguments to a function-    elabArgs :: IState -- ^ The current Idris state-             -> ElabCtxt -- ^ (in an argument, guarded, in a type, in a qquote)-             -> [Bool]-             -> FC -- ^ Source location-             -> Bool-             -> Name -- ^ Name of the function being applied-             -> [((Name, Name), Bool)] -- ^ (Argument Name, Hole Name, unmatchable)-             -> Bool -- ^ under a 'force'-             -> [PTerm] -- ^ argument-             -> ElabD ()-    elabArgs ist ina failed fc retry f [] force _ = return ()-    elabArgs ist ina failed fc r f (((argName, holeName), unm):ns) force (t : args)-        = do hs <- get_holes-             if holeName `elem` hs then -                do focus holeName-                   case t of-                      Placeholder -> do movelast holeName-                                        elabArgs ist ina failed fc r f ns force args-                      _ -> elabArg t-                else elabArgs ist ina failed fc r f ns force args-      where elabArg t =-              do -- solveAutos ist fn False-                 now_elaborating fc f argName-                 wrapErr f argName $ do-                   hs <- get_holes-                   tm <- get_term-                   -- No coercing under an explicit Force (or it can Force/Delay-                   -- recursively!)-                   let elab = if force then elab' else elabE-                   failed' <- -- trace (show (n, t, hs, tm)) $-                              -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $-                              do focus holeName;-                                 g <- goal-                                 -- Can't pattern match on polymorphic goals-                                 poly <- goal_polymorphic-                                 ulog <- getUnifyLog-                                 traceWhen ulog ("Elaborating argument " ++ show (argName, holeName, g)) $-                                  elab (ina { e_nomatching = unm && poly }) (Just fc) t-                                 return failed-                   done_elaborating_arg f argName-                   elabArgs ist ina failed fc r f ns force args-            wrapErr f argName action =-              do elabState <- get-                 while <- elaborating_app-                 let while' = map (\(x, y, z)-> (y, z)) while-                 (result, newState) <- case runStateT action elabState of-                                         OK (res, newState) -> return (res, newState)-                                         Error e -> do done_elaborating_arg f argName-                                                       lift (tfail (elaboratingArgErr while' e))-                 put newState-                 return result-    elabArgs _ _ _ _ _ _ (((arg, hole), _) : _) _ [] =-      fail $ "Can't elaborate these args: " ++ show arg ++ " " ++ show hole---- For every alternative, look at the function at the head. Automatically resolve--- any nested alternatives where that function is also at the head--pruneAlt :: [PTerm] -> [PTerm]-pruneAlt xs = map prune xs-  where-    prune (PApp fc1 (PRef fc2 f) as)-        = PApp fc1 (PRef fc2 f) (fmap (fmap (choose f)) as)-    prune t = t--    choose f (PAlternative a as)-        = let as' = fmap (choose f) as-              fs = filter (headIs f) as' in-              case fs of-                 [a] -> a-                 _ -> PAlternative a as'--    choose f (PApp fc f' as) = PApp fc (choose f f') (fmap (fmap (choose f)) as)-    choose f t = t--    headIs f (PApp _ (PRef _ f') _) = f == f'-    headIs f (PApp _ f' _) = headIs f f'-    headIs f _ = True -- keep if it's not an application---- Rule out alternatives that don't return the same type as the head of the goal--- (If there are none left as a result, do nothing)-pruneByType :: [Name] -> Term -> -- head of the goal-               Context -> [PTerm] -> [PTerm]--- if an alternative has a locally bound name at the head, take it-pruneByType env t c as-   | Just a <- locallyBound as = [a]-  where-    locallyBound [] = Nothing-    locallyBound (t:ts)-       | Just n <- getName t,-         n `elem` env = Just t-       | otherwise = locallyBound ts-    getName (PRef _ n) = Just n-    getName (PApp _ f _) = getName f-    getName (PHidden t) = getName t-    getName _ = Nothing--pruneByType env (P _ n _) ctxt as--- if the goal type is polymorphic, keep e-   | [] <- lookupTy n ctxt = as-   | otherwise-       = let asV = filter (headIs True n) as-             as' = filter (headIs False n) as in-             case as' of-               [] -> case asV of-                        [] -> as-                        _ -> asV-               _ -> as'-  where-    headIs var f (PApp _ (PRef _ f') _) = typeHead var f f'-    headIs var f (PApp _ f' _) = headIs var f f'-    headIs var f (PPi _ _ _ sc) = headIs var f sc-    headIs var f (PHidden t) = headIs var f t-    headIs _ _ _ = True -- keep if it's not an application--    typeHead var f f'-        = -- trace ("Trying " ++ show f' ++ " for " ++ show n) $-          case lookupTy f' ctxt of-               [ty] -> case unApply (getRetTy ty) of-                            (P _ ctyn _, _) | isConName ctyn ctxt -> ctyn == f-                            _ -> let ty' = normalise ctxt [] ty in-                                     case unApply (getRetTy ty') of-                                          (P _ ftyn _, _) -> ftyn == f-                                          (V _, _) -> var -- keep, variable-                                          _ -> False-               _ -> False--pruneByType _ t _ as = as--findInstances :: IState -> Term -> [Name]-findInstances ist t-    | (P _ n _, _) <- unApply t-        = case lookupCtxt n (idris_classes ist) of-            [CI _ _ _ _ _ ins _] -> filter accessible ins-            _ -> []-    | otherwise = []-  where accessible n = case lookupDefAccExact n False (tt_ctxt ist) of-                            Just (_, Hidden) -> False-                            _ -> True---- Try again to solve auto implicits-solveAuto :: IState -> Name -> Bool -> Name -> ElabD ()-solveAuto ist fn ambigok n-           = do hs <- get_holes-                when (n `elem` hs) $ do-                  focus n-                  g <- goal-                  isg <- is_guess -- if it's a guess, we're working on it recursively, so stop-                  when (not isg) $-                    proofSearch' ist True ambigok 100 True Nothing fn []--solveAutos :: IState -> Name -> Bool -> ElabD ()-solveAutos ist fn ambigok-           = do autos <- get_autos-                mapM_ (solveAuto ist fn ambigok) (map fst autos)--trivial' ist-    = trivial (elab ist toplevel ERHS [] (sMN 0 "tac")) ist-proofSearch' ist rec ambigok depth prv top n hints-    = do unifyProblems-         proofSearch rec prv ambigok (not prv) depth-                     (elab ist toplevel ERHS [] (sMN 0 "tac")) top n hints ist---- Resolve type classes. This will only pick up 'normal' instances, never--- named instances (hence using 'tcname' to check it's a generated instance--- name).-resolveTC :: Bool -- using default Int-             -> Bool -- allow metavariables in the goal -             -> Int -- depth-             -> Term -- top level goal-             -> Name -- top level function name-             -> IState -> ElabD ()-resolveTC def mvok depth top fn ist-   = do hs <- get_holes-        resTC' [] def hs depth top fn ist--resTC' tcs def topholes 0 topg fn ist = fail $ "Can't resolve type class"-resTC' tcs def topholes 1 topg fn ist = try' (trivial' ist) (resolveTC def False 0 topg fn ist) True-resTC' tcs defaultOn topholes depth topg fn ist-  = do compute-       g <- goal-       let argsok = tcArgsOK g topholes---        trace (show (g,hs,argsok,topholes)) $ -       if not argsok -- && not mvok)-         then lift $ tfail $ CantResolve True topg-         else do-           ptm <- get_term-           ulog <- getUnifyLog-           hs <- get_holes-           traceWhen ulog ("Resolving class " ++ show g) $-            try' (trivial' ist)-                (do t <- goal-                    let (tc, ttypes) = unApply t-                    scopeOnly <- needsDefault t tc ttypes-                    let stk = elab_stack ist-                    let insts_in = findInstances ist t-                    let insts = if scopeOnly then filter chaser insts_in-                                    else insts_in-                    tm <- get_term-                    let depth' = if scopeOnly then 2 else depth-                    blunderbuss t depth' stk (stk ++ insts)) True-  where-    tcArgsOK ty hs | (P _ nc _, as) <- unApply ty, nc == numclass && defaultOn-       = True-    tcArgsOK ty hs -- if any arguments are metavariables, postpone-       = let (f, as) = unApply ty in-             case f of-                  P _ cn _ -> case lookupCtxtExact cn (idris_classes ist) of-                                   Just ci -> tcDetArgsOK 0 (class_determiners ci) hs as-                                   Nothing -> not $ any (isMeta hs) as-                  _ -> not $ any (isMeta hs) as--    tcDetArgsOK i ds hs (x : xs)-        | i `elem` ds = not (isMeta hs x) && tcDetArgsOK (i + 1) ds hs xs-        | otherwise = tcDetArgsOK (i + 1) ds hs xs-    tcDetArgsOK _ _ _ [] = True--    isMeta :: [Name] -> Term -> Bool-    isMeta ns (P _ n _) = n `elem` ns -    isMeta _ _ = False--    notHole hs (P _ n _, c)-       | (P _ cn _, _) <- unApply c,-         n `elem` hs && isConName cn (tt_ctxt ist) = False-       | Constant _ <- c = not (n `elem` hs)-    notHole _ _ = True--    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 nm)-        | ('@':'@':_) <- str nm = True -- old way-    chaser (SN (ParentN _ _)) = True-    chaser (NS n _) = chaser n-    chaser _ = False--    numclass = sNS (sUN "Num") ["Classes","Prelude"]--    needsDefault t num@(P _ nc _) [P Bound a _] | nc == numclass && defaultOn-        = do focus a-             fill (RConstant (AType (ATInt ITBig))) -- default Integer-             solve-             return False-    needsDefault t f as-          | all boundVar as = return True -- fail $ "Can't resolve " ++ show t-    needsDefault t f a = return False -- trace (show t) $ return ()--    boundVar (P Bound _ _) = True-    boundVar _ = False--    blunderbuss t d stk [] = do -- c <- get_env-                            -- ps <- get_probs-                            lift $ tfail $ CantResolve False topg-    blunderbuss t d stk (n:ns)-        | n /= fn && (n `elem` stk || tcname n) -              = tryCatch (resolve n d) -                    (\e -> case e of-                             CantResolve True _ -> lift $ tfail e-                             _ -> blunderbuss t d stk ns) -        | otherwise = blunderbuss t d stk ns--    resolve n depth-       | depth == 0 = fail $ "Can't resolve type class"-       | otherwise-           = do t <- goal-                let (tc, ttypes) = unApply t---                 if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist---                   else do-                   -- if there's a hole in the goal, don't even try-                let imps = case lookupCtxtName n (idris_implicits ist) of-                                [] -> []-                                [args] -> map isImp (snd args) -- won't be overloaded!-                                xs -> error "The impossible happened - overloading is not expected here!"-                ps <- get_probs-                tm <- get_term-                args <- map snd <$> try' (apply (Var n) imps)-                                         (match_apply (Var n) imps) True-                ps' <- get_probs-                when (length ps < length ps' || unrecoverable ps') $-                     fail "Can't apply type class"---                 traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $-                mapM_ (\ (_,n) -> do focus n-                                     t' <- goal-                                     let (tc', ttype) = unApply t'-                                     let got = fst (unApply t)-                                     let depth' = if tc' `elem` tcs-                                                     then depth - 1 else depth-                                     resTC' (got : tcs) defaultOn topholes depth' topg fn ist)-                      (filter (\ (x, y) -> not x) (zip (map fst imps) args))-                -- if there's any arguments left, we've failed to resolve-                hs <- get_holes-                ulog <- getUnifyLog-                solve-                traceWhen ulog ("Got " ++ show n) $ return ()-       where isImp (PImp p _ _ _ _) = (True, p)-             isImp arg = (False, priority arg)--collectDeferred :: Maybe Name ->-                   Term -> State [(Name, (Int, Maybe Name, Type))] Term-collectDeferred top (Bind n (GHole i t) app) =-    do ds <- get-       t' <- collectDeferred top t-       when (not (n `elem` map fst ds)) $ put (ds ++ [(n, (i, top, t'))])-       collectDeferred top app-collectDeferred top (Bind n b t) = do b' <- cdb b-                                      t' <- collectDeferred top t-                                      return (Bind n b' t')-  where-    cdb (Let t v)   = liftM2 Let (collectDeferred top t) (collectDeferred top v)-    cdb (Guess t v) = liftM2 Guess (collectDeferred top t) (collectDeferred top v)-    cdb b           = do ty' <- collectDeferred top (binderTy b)-                         return (b { binderTy = ty' })-collectDeferred top (App f a) = liftM2 App (collectDeferred top f) (collectDeferred top a)-collectDeferred top t = return t--case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()-case_ ind autoSolve ist fn tm = do-  attack-  tyn <- getNameFrom (sMN 0 "ity")-  claim tyn RType-  valn <- getNameFrom (sMN 0 "ival")-  claim valn (Var tyn)-  letn <- getNameFrom (sMN 0 "irule")-  letbind letn (Var tyn) (Var valn)-  focus valn-  elab ist toplevel ERHS [] (sMN 0 "tac") tm-  env <- get_env-  let (Just binding) = lookup letn env-  let val = binderVal binding-  if ind then induction (forget val)-         else casetac (forget val)-  when autoSolve solveAll--tacN :: String -> Name-tacN str = sNS (sUN str) ["Tactical", "Reflection", "Language"]--runTactical :: FC -> Env -> Term -> ElabD ()-runTactical fc env tm = do tm' <- eval tm-                           runTacTm tm'-                           return ()-  where-    eval tm = do ctxt <- get_context-                 return $ normaliseAll ctxt env (finalise tm)--    returnUnit = fmap fst $ get_type_val (Var unitCon)--    -- | Do a step in the reflected elaborator monad. The input is the-    -- step, the output is the (reflected) term returned.-    runTacTm :: Term -> ElabD Term-    runTacTm (unApply -> tac@(P _ n _, args))-      | n == tacN "prim__Solve", [] <- args-      = do solve-           returnUnit-      | n == tacN "prim__Goal", [] <- args-      = do (h:_) <- get_holes-           t <- goal-           fmap fst . get_type_val $-             rawPair (Var (reflm "TTName"), Var (reflm "TT"))-                     (reflectName h,        reflect t)-      | n == tacN "prim__Holes", [] <- args-      = do hs <- get_holes-           fmap fst . get_type_val $-             mkList (Var $ reflm "TTName") (map reflectName hs)-      | n == tacN "prim__Guess", [] <- args-      = do ok <- is_guess-           if ok-              then do guess <- fmap forget get_guess-                      fmap fst . get_type_val $-                        RApp (RApp (Var (sNS (sUN "Just") ["Maybe", "Prelude"]))-                                   (Var (reflm "TT")))-                             guess-              else fmap fst . get_type_val $-                     RApp (Var (sNS (sUN "Nothing") ["Maybe", "Prelude"]))-                          (Var (reflm "TT"))-      | n == tacN "prim__SourceLocation", [] <- args-      = fmap fst . get_type_val $-          reflectFC fc-      | n == tacN "prim__Env", [] <- args-      = do env <- get_env-           fmap fst . get_type_val $ reflectEnv env-      | n == tacN "prim__Fail", [_a, errs] <- args-      = do errs' <- eval errs-           parts <- reifyReportParts errs'-           lift . tfail $ ReflectionError [parts] (Msg "")-      | n == tacN "prim__PureTactical", [_a, tm] <- args-      = return tm-      | n == tacN "prim__BindTactical", [_a, _b, first, andThen] <- args-      = do first' <- eval first-           res <- runTacTm first'-           next <- eval (App andThen res)-           runTacTm next-      | n == tacN "prim__Try", [_a, first, alt] <- args-      = do first' <- eval first-           alt' <- eval alt-           try' (runTacTm first') (runTacTm alt') True-      | n == tacN "prim__Fill", [raw] <- args-      = do raw' <- reifyRaw raw-           apply raw' []-           returnUnit-      | n == tacN "prim__Gensym", [hint] <- args-      = do hintStr <- eval hint-           case hintStr of-             Constant (Str h) -> do-               n <- getNameFrom (sMN 0 h)-               fmap fst $ get_type_val (reflectName n)-             _ -> fail "no hint"-      | n == tacN "prim__Claim", [n, ty] <- args-      = do n' <- reifyTTName n-           ty' <- reifyRaw ty-           claim n' ty'-           returnUnit-      | n == tacN "prim__Forget", [tt] <- args-      = do tt' <- reifyTT tt-           fmap fst . get_type_val $ reflect tt'-      | n == tacN "prim__Attack", [] <- args-      = do attack-           returnUnit-      | n == tacN "prim__Rewrite", [rule] <- args-      = do r <- reifyRaw rule-           rewrite r-           returnUnit-      | n == tacN "prim__Focus", [what] <- args-      = do n' <- reifyTTName what-           focus n'-           returnUnit-      | n == tacN "prim__Unfocus", [what] <- args-      = do n' <- reifyTTName what-           movelast n'-           returnUnit-      | n == tacN "prim__Intro", [mn] <- args-      = do n <- case fromTTMaybe mn of-                  Nothing -> return Nothing-                  Just name -> fmap Just $ reifyTTName name-           intro n-           returnUnit-      | n == tacN "prim__DeclareType", [decl] <- args-      = do (RDeclare n args res) <- reifyTyDecl decl-           ctxt <- get_context-           let mkPi arg res = RBind (argName arg)-                                    (Pi Nothing (argTy arg) (RUType AllTypes))-                                    res-               rty = foldr mkPi res args-           (checked, ty') <- lift $ check ctxt [] rty-           case normaliseAll ctxt [] (finalise ty') of-             TType _ -> lift . tfail . InternalMsg $-                          show checked ++ " is not a type: it's " ++ show ty'-             _       -> return ()-           case lookupDefExact n ctxt of-             Just _ -> lift . tfail . InternalMsg $-                         show n ++ " is already defined."-             Nothing -> return ()-           let decl = TyDecl Ref checked-               ctxt' = addCtxtDef n decl ctxt-           set_context ctxt'-           updateAux $ \e -> e { new_tyDecls = (n, fc, map rArgToPArg args, checked) :-                                               new_tyDecls e }-           aux <- getAux-           returnUnit-      | n == tacN "prim__Debug", [ty, msg] <- args-      = do let msg' = fromTTMaybe msg-           case msg' of-             Nothing -> debugElaborator Nothing-             Just (Constant (Str m)) -> debugElaborator (Just m)-             Just x -> lift . tfail . InternalMsg $ "Can't reify message for debugging: " ++ show x-    runTacTm x = lift . tfail . InternalMsg $ "tactical is not implemented for " ++ show x---- Running tactics directly--- if a tactic adds unification problems, return an error--runTac :: Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()-runTac autoSolve ist perhapsFC fn tac-    = do env <- get_env-         g <- goal-         let tac' = fmap (addImplBound ist (map fst env)) tac-         if autoSolve-            then runT tac'-            else no_errors (runT tac')-                   (Just (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env)))-  where-    runT (Intro []) = do g <- goal-                         attack; intro (bname g)-      where-        bname (Bind n _ _) = Just n-        bname _ = Nothing-    runT (Intro xs) = mapM_ (\x -> do attack; intro (Just x)) xs-    runT Intros = do g <- goal-                     attack; -                     intro (bname g)-                     try' (runT Intros)-                          (return ()) True-      where-        bname (Bind n _ _) = Just n-        bname _ = Nothing-    runT (Exact tm) = do elab ist toplevel ERHS [] (sMN 0 "tac") tm-                         when autoSolve solveAll-    runT (MatchRefine fn)-        = do fnimps <--               case lookupCtxtName fn (idris_implicits ist) of-                    [] -> do a <- envArgs fn-                             return [(fn, a)]-                    ns -> return (map (\ (n, a) -> (n, map (const True) a)) ns)-             let tacs = map (\ (fn', imps) ->-                                 (match_apply (Var fn') (map (\x -> (x, 0)) imps),-                                     fn')) fnimps-             tryAll tacs-             when autoSolve solveAll-       where envArgs n = do e <- get_env-                            case lookup n e of-                               Just t -> return $ map (const False)-                                                      (getArgTys (binderTy t))-                               _ -> return []-    runT (Refine fn [])-        = do fnimps <--               case lookupCtxtName fn (idris_implicits ist) of-                    [] -> do a <- envArgs fn-                             return [(fn, a)]-                    ns -> return (map (\ (n, a) -> (n, map isImp a)) ns)-             let tacs = map (\ (fn', imps) ->-                                 (apply (Var fn') (map (\x -> (x, 0)) imps),-                                     fn')) fnimps-             tryAll tacs-             when autoSolve solveAll-       where isImp (PImp _ _ _ _ _) = True-             isImp _ = False-             envArgs n = do e <- get_env-                            case lookup n e of-                               Just t -> return $ map (const False)-                                                      (getArgTys (binderTy t))-                               _ -> return []-    runT (Refine fn imps) = do ns <- apply (Var fn) (map (\x -> (x,0)) imps)-                               when autoSolve solveAll-    runT DoUnify = do unify_all-                      when autoSolve solveAll-    runT (Claim n tm) = do tmHole <- getNameFrom (sMN 0 "newGoal")-                           claim tmHole RType-                           claim n (Var tmHole)-                           focus tmHole-                           elab ist toplevel ERHS [] (sMN 0 "tac") tm-                           focus n-    runT (Equiv tm) -- let bind tm, then-              = do attack-                   tyn <- getNameFrom (sMN 0 "ety")-                   claim tyn RType-                   valn <- getNameFrom (sMN 0 "eqval")-                   claim valn (Var tyn)-                   letn <- getNameFrom (sMN 0 "equiv_val")-                   letbind letn (Var tyn) (Var valn)-                   focus tyn-                   elab ist toplevel ERHS [] (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 <- getNameFrom (sMN 0 "rty")-                   -- start_unify h-                   claim tyn RType-                   valn <- getNameFrom (sMN 0 "rval")-                   claim valn (Var tyn)-                   letn <- getNameFrom (sMN 0 "rewrite_rule")-                   letbind letn (Var tyn) (Var valn)-                   focus valn-                   elab ist toplevel ERHS [] (sMN 0 "tac") tm-                   rewrite (Var letn)-                   when autoSolve solveAll-    runT (Induction tm) -- let bind tm, similar to the others-              = case_ True autoSolve ist fn tm-    runT (CaseTac tm)-              = case_ False autoSolve ist fn tm-    runT (LetTac n tm)-              = do attack-                   tyn <- getNameFrom (sMN 0 "letty")-                   claim tyn RType-                   valn <- getNameFrom (sMN 0 "letval")-                   claim valn (Var tyn)-                   letn <- unique_hole n-                   letbind letn (Var tyn) (Var valn)-                   focus valn-                   elab ist toplevel ERHS [] (sMN 0 "tac") tm-                   when autoSolve solveAll-    runT (LetTacTy n ty tm)-              = do attack-                   tyn <- getNameFrom (sMN 0 "letty")-                   claim tyn RType-                   valn <- getNameFrom (sMN 0 "letval")-                   claim valn (Var tyn)-                   letn <- unique_hole n-                   letbind letn (Var tyn) (Var valn)-                   focus tyn-                   elab ist toplevel ERHS [] (sMN 0 "tac") ty-                   focus valn-                   elab ist toplevel ERHS [] (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 rec prover depth top hints)-         = do proofSearch' ist rec False depth prover top fn hints-              when autoSolve solveAll-    runT (Focus n) = focus n-    runT Unfocus = do hs <- get_holes-                      case hs of-                        []      -> return ()-                        (h : _) -> movelast h-    runT Solve = solve-    runT (Try l r) = do try' (runT l) (runT r) True-    runT (TSeq l r) = do runT l; runT r-    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 <- getNameFrom (sMN 0 "script")-                               claim script scriptTy-                               scriptvar <- getNameFrom (sMN 0 "scriptvar" )-                               letbind scriptvar scriptTy (Var script)-                               focus script-                               elab ist toplevel ERHS [] (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 <- getNameFrom (sMN 0 "restac")-                               claim restac tacticTy-                               focus restac-                               fill (raw_apply (forget script')-                                               [reflectEnv tenv, reflect tgoal])-                               restac' <- get_guess-                               solve-                               -- normalise the result in order to-                               -- reify it-                               ctxt <- get_context-                               env <- get_env-                               let tactic = normalise ctxt env restac'-                               runReflected tactic-        where tacticTy = Var (reflm "Tactic")-              listTy = Var (sNS (sUN "List") ["List", "Prelude"])-              scriptTy = (RBind (sMN 0 "__pi_arg")-                                (Pi Nothing (RApp listTy envTupleType) RType)-                                    (RBind (sMN 1 "__pi_arg")-                                           (Pi Nothing (Var $ reflm "TT") RType) 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 ERHS [] (sMN 0 "tac")-                  (PApp emptyFC tm [pexp (delabTy' ist [] tgoal True True)])-             (script', _) <- get_type_val (Var scriptvar)-             -- now that we have the script apply-             -- it to the reflected goal-             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 <- getNameFrom (sMN 0 "letty")-                          claim tyn RType-                          valn <- getNameFrom (sMN 0 "letval")-                          claim valn (Var tyn)-                          letn <- getNameFrom (sMN 0 "letvar")-                          letbind letn (Var tyn) (Var valn)-                          focus valn-                          elab ist toplevel ERHS [] (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 perhapsFC fn (Exact $ PQuote (reflect value'))-    runT (Fill v) = do attack -- let x = fill x in ...-                       tyn <- getNameFrom (sMN 0 "letty")-                       claim tyn RType-                       valn <- getNameFrom (sMN 0 "letval")-                       claim valn (Var tyn)-                       letn <- getNameFrom (sMN 0 "letvar")-                       letbind letn (Var tyn) (Var valn)-                       focus valn-                       elab ist toplevel ERHS [] (sMN 0 "tac") v-                       (value, _) <- get_type_val (Var letn)-                       ctxt <- get_context-                       env <- get_env-                       let value' = normalise ctxt env value-                       rawValue <- reifyRaw value'-                       runTac autoSolve ist perhapsFC fn (Exact $ PQuote rawValue)-    runT (GoalType n tac) = do g <- goal-                               case unApply g of-                                    (P _ n' _, _) ->-                                       if nsroot n' == sUN n-                                          then runT tac-                                          else fail "Wrong goal type"-                                    _ -> fail "Wrong goal type"-    runT ProofState = do g <- goal-                         return ()-    runT Skip = return ()-    runT (TFail err) = lift . tfail $ ReflectionError [err] (Msg "")-    runT SourceFC =-      case perhapsFC of-        Nothing -> lift . tfail $ Msg "There is no source location available."-        Just fc ->-          do fill $ reflectFC fc-             solve-    runT Qed = lift . tfail $ Msg "The qed command is only valid in the interactive prover"-    runT x = fail $ "Not implemented " ++ show x--    runReflected t = do t' <- reify ist t-                        runTac autoSolve ist perhapsFC fn t'---- | Prefix a name with the "Language.Reflection" namespace-reflm :: String -> Name-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 _ (P _ n _) | n == reflm "Skip" = return Skip-reify _ (P _ n _) | n == reflm "SourceFC" = return SourceFC-reify _ (P _ n _) | n == reflm "Unfocus" = return Unfocus-reify ist t@(App _ _)-          | (P _ f _, args) <- unApply t = reifyApp ist f args-reify _ t = fail ("Unknown tactic " ++ show t)--reifyApp :: IState -> Name -> [Term] -> ElabD PTactic-reifyApp ist t [l, r] | t == reflm "Try" = liftM2 Try (reify ist l) (reify ist r)-reifyApp _ t [Constant (I i)]-           | t == reflm "Search" = return (ProofSearch True True i Nothing [])-reifyApp _ t [x]-           | t == reflm "Refine" = do n <- reifyTTName x-                                      return $ Refine n []-reifyApp ist t [n, ty] | t == reflm "Claim" = do n' <- reifyTTName n-                                                 goal <- reifyTT ty-                                                 return $ Claim n' (delab ist goal)-reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist r)-reifyApp ist t [Constant (Str n), x]-             | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)-reifyApp _ t [n] | t == reflm "Intro" = liftM (Intro . (:[])) (reifyTTName n)-reifyApp ist t [t'] | t == reflm "Induction" = liftM (Induction . delab ist) (reifyTT t')-reifyApp ist t [t'] | t == reflm "Case" = liftM (Induction . delab ist) (reifyTT t')-reifyApp ist t [t']-             | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')-reifyApp ist t [t']-             | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')-reifyApp ist t [t']-             | t == reflm "ByReflection" = liftM (ByReflection . delab ist) (reifyTT t')-reifyApp _ t [t']-           | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t')-reifyApp ist t [t']-             | t == reflm "Exact" = liftM (Exact . delab ist) (reifyTT t')-reifyApp ist t [x]-             | t == reflm "Focus" = liftM Focus (reifyTTName x)-reifyApp ist t [t']-             | t == reflm "Rewrite" = liftM (Rewrite . delab ist) (reifyTT t')-reifyApp ist t [n, t']-             | t == reflm "LetTac" = do n'  <- reifyTTName n-                                        t'' <- reifyTT t'-                                        return $ LetTac n' (delab ist t')-reifyApp ist t [n, tt', t']-             | t == reflm "LetTacTy" = do n'   <- reifyTTName n-                                          tt'' <- reifyTT tt'-                                          t''  <- reifyTT t'-                                          return $ LetTacTy n' (delab ist tt'') (delab ist t'')-reifyApp ist t [errs]-             | t == reflm "Fail" = fmap TFail (reifyReportParts errs)-reifyApp _ f args = fail ("Unknown tactic " ++ show (f, args)) -- shouldn't happen--reifyReportParts :: Term -> ElabD [ErrorReportPart]-reifyReportParts errs =-  case unList errs of-    Nothing -> fail "Failed to reify errors"-    Just errs' ->-      let parts = mapM reifyReportPart errs' in-      case parts of-        Left err -> fail $ "Couldn't reify \"Fail\" tactic - " ++ show err-        Right errs'' ->-          return errs''---- | Reify terms from their reflected representation-reifyTT :: Term -> ElabD Term-reifyTT t@(App _ _)-        | (P _ f _, args) <- unApply t = reifyTTApp f args-reifyTT t@(P _ n _)-        | n == reflm "Erased" = return $ Erased-reifyTT t@(P _ n _)-        | n == reflm "Impossible" = return $ Impossible-reifyTT t = fail ("Unknown reflection term: " ++ show t)--reifyTTApp :: Name -> [Term] -> ElabD Term-reifyTTApp t [nt, n, x]-           | t == reflm "P" = do nt' <- reifyTTNameType nt-                                 n'  <- reifyTTName n-                                 x'  <- reifyTT x-                                 return $ P nt' n' x'-reifyTTApp t [Constant (I i)]-           | t == reflm "V" = return $ V i-reifyTTApp t [n, b, x]-           | t == reflm "Bind" = do n' <- reifyTTName n-                                    b' <- reifyTTBinder reifyTT (reflm "TT") b-                                    x' <- reifyTT x-                                    return $ Bind n' b' x'-reifyTTApp t [f, x]-           | t == reflm "App" = do f' <- reifyTT f-                                   x' <- reifyTT x-                                   return $ App f' x'-reifyTTApp t [c]-           | t == reflm "TConst" = liftM Constant (reifyTTConst c)-reifyTTApp t [t', Constant (I i)]-           | t == reflm "Proj" = do t'' <- reifyTT t'-                                    return $ Proj t'' i-reifyTTApp t [tt]-           | t == reflm "TType" = liftM TType (reifyTTUExp tt)-reifyTTApp t args = fail ("Unknown reflection term: " ++ show (t, args))---- | Reify raw terms from their reflected representation-reifyRaw :: Term -> ElabD Raw-reifyRaw t@(App _ _)-         | (P _ f _, args) <- unApply t = reifyRawApp f args-reifyRaw t@(P _ n _)-         | n == reflm "RType" = return $ RType-reifyRaw t = fail ("Unknown reflection raw term in reifyRaw: " ++ show t)--reifyRawApp :: Name -> [Term] -> ElabD Raw-reifyRawApp t [n]-            | t == reflm "Var" = liftM Var (reifyTTName n)-reifyRawApp t [n, b, x]-            | t == reflm "RBind" = do n' <- reifyTTName n-                                      b' <- reifyTTBinder reifyRaw (reflm "Raw") b-                                      x' <- reifyRaw x-                                      return $ RBind n' b' x'-reifyRawApp t [f, x]-            | t == reflm "RApp" = liftM2 RApp (reifyRaw f) (reifyRaw x)-reifyRawApp t [t']-            | t == reflm "RForce" = liftM RForce (reifyRaw t')-reifyRawApp t [c]-            | t == reflm "RConstant" = liftM RConstant (reifyTTConst c)-reifyRawApp t args = fail ("Unknown reflection raw term in reifyRawApp: " ++ show (t, args))--reifyTTName :: Term -> ElabD Name-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 $ sUN n-reifyTTNameApp t [n, ns]-               | t == reflm "NS" = do n'  <- reifyTTName n-                                      ns' <- reifyTTNamespace ns-                                      return $ sNS n' ns'-reifyTTNameApp t [Constant (I i), Constant (Str 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))--reifyTTNamespace :: Term -> ElabD [String]-reifyTTNamespace t@(App _ _)-  = case unApply t of-      (P _ f _, [Constant StrType])-           | f == sNS (sUN "Nil") ["List", "Prelude"] -> return []-      (P _ f _, [Constant StrType, Constant (Str n), 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)--reifyTTNameType :: Term -> ElabD NameType-reifyTTNameType t@(P _ n _) | n == reflm "Bound" = return $ Bound-reifyTTNameType t@(P _ n _) | n == reflm "Ref" = return $ Ref-reifyTTNameType t@(App _ _)-  = case unApply t of-      (P _ f _, [Constant (I tag), Constant (I num)])-           | f == reflm "DCon" -> return $ DCon tag num False -- FIXME: Uniqueness!-           | f == reflm "TCon" -> return $ TCon tag num-      _ -> fail ("Unknown reflection name type: " ++ show t)-reifyTTNameType t = fail ("Unknown reflection name type: " ++ show t)--reifyTTBinder :: (Term -> ElabD a) -> Name -> Term -> ElabD (Binder a)-reifyTTBinder reificator binderType t@(App _ _)-  = case unApply t of-     (P _ f _, bt:args) | forget bt == Var binderType-       -> reifyTTBinderApp reificator f args-     _ -> fail ("Mismatching binder reflection: " ++ show t)-reifyTTBinder _ _ t = fail ("Unknown reflection binder: " ++ show t)--reifyTTBinderApp :: (Term -> ElabD a) -> Name -> [Term] -> ElabD (Binder a)-reifyTTBinderApp reif f [t]-                      | f == reflm "Lam" = liftM Lam (reif t)-reifyTTBinderApp reif f [t, k]-                      | f == reflm "Pi" = liftM2 (Pi Nothing) (reif t) (reif k)-reifyTTBinderApp reif f [x, y]-                      | f == reflm "Let" = liftM2 Let (reif x) (reif y)-reifyTTBinderApp reif f [x, y]-                      | f == reflm "NLet" = liftM2 NLet (reif x) (reif y)-reifyTTBinderApp reif f [t]-                      | f == reflm "Hole" = liftM Hole (reif t)-reifyTTBinderApp reif f [t]-                      | f == reflm "GHole" = liftM (GHole 0) (reif t)-reifyTTBinderApp reif f [x, y]-                      | f == reflm "Guess" = liftM2 Guess (reif x) (reif y)-reifyTTBinderApp reif f [t]-                      | f == reflm "PVar" = liftM PVar (reif t)-reifyTTBinderApp reif f [t]-                      | f == reflm "PVTy" = liftM PVTy (reif t)-reifyTTBinderApp _ f args = fail ("Unknown reflection binder: " ++ show (f, args))--reifyTTConst :: Term -> ElabD Const-reifyTTConst (P _ n _) | n == reflm "StrType"  = return $ StrType-reifyTTConst (P _ n _) | n == reflm "PtrType"  = return $ PtrType-reifyTTConst (P _ n _) | n == reflm "VoidType" = return $ VoidType-reifyTTConst (P _ n _) | n == reflm "Forgot"   = return $ Forgot-reifyTTConst t@(App _ _)-             | (P _ f _, [arg]) <- unApply t   = reifyTTConstApp f arg-reifyTTConst t = fail ("Unknown reflection constant: " ++ show t)--reifyTTConstApp :: Name -> Term -> ElabD Const-reifyTTConstApp f aty-                | f == reflm "AType" = fmap AType (reifyArithTy aty)-reifyTTConstApp f (Constant c@(I _))-                | f == reflm "I"   = return $ c-reifyTTConstApp f (Constant c@(BI _))-                | f == reflm "BI"  = return $ c-reifyTTConstApp f (Constant c@(Fl _))-                | f == reflm "Fl"  = return $ c-reifyTTConstApp f (Constant c@(I _))-                | f == reflm "Ch"  = return $ c-reifyTTConstApp f (Constant c@(Str _))-                | f == reflm "Str" = return $ c-reifyTTConstApp f (Constant c@(B8 _))-                | f == reflm "B8"  = return $ c-reifyTTConstApp f (Constant c@(B16 _))-                | f == reflm "B16" = return $ c-reifyTTConstApp f (Constant c@(B32 _))-                | f == reflm "B32" = return $ c-reifyTTConstApp f (Constant c@(B64 _))-                | f == reflm "B64" = return $ c-reifyTTConstApp f arg = fail ("Unknown reflection constant: " ++ show (f, arg))--reifyArithTy :: Term -> ElabD ArithTy-reifyArithTy (App (P _ n _) intTy) | n == reflm "ATInt"   = fmap ATInt (reifyIntTy intTy)-reifyArithTy (P _ n _)             | n == reflm "ATFloat" = return ATFloat-reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)--reifyNativeTy :: Term -> ElabD NativeTy-reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8-reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8-reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8-reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8-reifyNativeTy x = fail $ "Couldn't reify reflected NativeTy " ++ show x--reifyIntTy :: Term -> ElabD IntTy-reifyIntTy (App (P _ n _) nt) | n == reflm "ITFixed" = fmap ITFixed (reifyNativeTy nt)-reifyIntTy (P _ n _) | n == reflm "ITNative" = return ITNative-reifyIntTy (P _ n _) | n == reflm "ITBig" = return ITBig-reifyIntTy (P _ n _) | n == reflm "ITChar" = return ITChar-reifyIntTy (App (App (P _ n _) nt) (Constant (I i))) | n == reflm "ITVec" = fmap (flip ITVec i)-                                                                                 (reifyNativeTy nt)-reifyIntTy tm = fail $ "The term " ++ show tm ++ " is not a reflected IntTy"--reifyTTUExp :: Term -> ElabD UExp-reifyTTUExp t@(App _ _)-  = case unApply t of-      (P _ f _, [Constant (I i)]) | f == reflm "UVar" -> return $ UVar i-      (P _ f _, [Constant (I i)]) | f == reflm "UVal" -> return $ UVal i-      _ -> fail ("Unknown reflection type universe expression: " ++ show t)-reifyTTUExp t = fail ("Unknown reflection type universe expression: " ++ show t)---- | Create a reflected call to a named function/constructor-reflCall :: String -> [Raw] -> Raw-reflCall funName args-  = raw_apply (Var (reflm funName)) args---- | Lift a term into its Language.Reflection.TT representation-reflect :: Term -> Raw-reflect = reflectTTQuote []---- | Lift a term into its Language.Reflection.Raw representation-reflectRaw :: Raw -> Raw-reflectRaw = reflectRawQuote []--claimTT :: Name -> ElabD Name-claimTT n = do n' <- getNameFrom n-               claim n' (Var (sNS (sUN "TT") ["Reflection", "Language"]))-               return n'---- | Convert a reflected term to a more suitable form for pattern-matching.--- In particular, the less-interesting bits are elaborated to _ patterns. This--- happens to NameTypes, universe levels, names that are bound but not used,--- and the type annotation field of the P constructor.-reflectTTQuotePattern :: [Name] -> Term -> ElabD ()-reflectTTQuotePattern unq (P _ n _)-  | n `elem` unq = -- the unquoted names have been claimed as TT already - just use them-    do fill (Var n) ; solve-  | otherwise =-    do tyannot <- claimTT (sMN 0 "pTyAnnot")-       movelast tyannot  -- use a _ pattern here-       nt <- getNameFrom (sMN 0 "nt")-       claim nt (Var (reflm "NameType"))-       movelast nt       -- use a _ pattern here-       n' <- getNameFrom (sMN 0 "n")-       claim n' (Var (reflm "TTName"))-       fill $ reflCall "P" [Var nt, Var n', Var tyannot]-       solve-       focus n'; reflectNameQuotePattern n-reflectTTQuotePattern unq (V n)-  = do fill $ reflCall "V" [RConstant (I n)]-       solve-reflectTTQuotePattern unq (Bind n b x)-  = do x' <- claimTT (sMN 0 "sc")-       movelast x'-       b' <- getNameFrom (sMN 0 "binder")-       claim b' (RApp (Var (sNS (sUN "Binder") ["Reflection", "Language"]))-                      (Var (sNS (sUN "TT") ["Reflection", "Language"])))-       if n `elem` freeNames x-         then do fill $ reflCall "Bind"-                                 [reflectName n,-                                  Var b',-                                  Var x']-                 solve-         else do any <- getNameFrom (sMN 0 "anyName")-                 claim any (Var (reflm "TTName"))-                 movelast any-                 fill $ reflCall "Bind"-                                 [Var any,-                                  Var b',-                                  Var x']-                 solve-       focus x'; reflectTTQuotePattern unq x-       focus b'; reflectBinderQuotePattern reflectTTQuotePattern unq b-reflectTTQuotePattern unq (App f x)-  = do f' <- claimTT (sMN 0 "f"); movelast f'-       x' <- claimTT (sMN 0 "x"); movelast x'-       fill $ reflCall "App" [Var f', Var x']-       solve-       focus f'; reflectTTQuotePattern unq f-       focus x'; reflectTTQuotePattern unq x-reflectTTQuotePattern unq (Constant c)-  = do fill $ reflCall "TConst" [reflectConstant c]-       solve-reflectTTQuotePattern unq (Proj t i)-  = do t' <- claimTT (sMN 0 "t"); movelast t'-       fill $ reflCall "Proj" [Var t', RConstant (I i)]-       solve-       focus t'; reflectTTQuotePattern unq t-reflectTTQuotePattern unq (Erased)-  = do erased <- claimTT (sMN 0 "erased")-       movelast erased-       fill $ (Var erased)-       solve-reflectTTQuotePattern unq (Impossible)-  = do fill $ Var (reflm "Impossible")-       solve-reflectTTQuotePattern unq (TType exp)-  = do ue <- getNameFrom (sMN 0 "uexp")-       claim ue (Var (sNS (sUN "TTUExp") ["Reflection", "Language"]))-       movelast ue-       fill $ reflCall "TType" [Var ue]-       solve-reflectTTQuotePattern unq (UType u)-  = do uH <- getNameFrom (sMN 0 "someUniv")-       claim uH (Var (reflm "Universe"))-       movelast uH-       fill $ reflCall "UType" [Var uH]-       solve-       focus uH-       fill (Var (reflm (case u of-                           NullType -> "NullType"-                           UniqueType -> "UniqueType"-                           AllTypes -> "AllTypes")))-       solve--reflectRawQuotePattern :: [Name] -> Raw -> ElabD ()-reflectRawQuotePattern unq (Var n)-  -- the unquoted names already have types, just use them-  | n `elem` unq = do fill (Var n); solve-  | otherwise = do fill (reflCall "Var" [reflectName n]); solve-reflectRawQuotePattern unq (RBind n b sc) =-  do scH <- getNameFrom (sMN 0 "sc")-     claim scH (Var (reflm "Raw"))-     movelast scH-     bH <- getNameFrom (sMN 0 "binder")-     claim bH (RApp (Var (reflm "Binder"))-                    (Var (reflm "Raw")))-     if n `elem` freeNamesR sc-        then do fill $ reflCall "RBind" [reflectName n,-                                         Var bH,-                                         Var scH]-                solve-        else do any <- getNameFrom (sMN 0 "anyName")-                claim any (Var (reflm "TTName"))-                movelast any-                fill $ reflCall "RBind" [Var any, Var bH, Var scH]-                solve-     focus scH; reflectRawQuotePattern unq sc-     focus bH; reflectBinderQuotePattern reflectRawQuotePattern unq b-  where freeNamesR (Var n) = [n]-        freeNamesR (RBind n (Let t v) body) = concat [freeNamesR v,-                                                      freeNamesR body \\ [n],-                                                      freeNamesR t]-        freeNamesR (RBind n b body) = freeNamesR (binderTy b) ++-                                      (freeNamesR body \\ [n])-        freeNamesR (RApp f x) = freeNamesR f ++ freeNamesR x-        freeNamesR RType = []-        freeNamesR (RUType _) = []-        freeNamesR (RForce r) = freeNamesR r-        freeNamesR (RConstant _) = []-reflectRawQuotePattern unq (RApp f x) =-  do fH <- getNameFrom (sMN 0 "f")-     claim fH (Var (reflm "Raw"))-     movelast fH-     xH <- getNameFrom (sMN 0 "x")-     claim xH (Var (reflm "Raw"))-     movelast xH-     fill $ reflCall "RApp" [Var fH, Var xH]-     solve-     focus fH; reflectRawQuotePattern unq f-     focus xH; reflectRawQuotePattern unq x-reflectRawQuotePattern unq RType =-  do fill (Var (reflm "RType"))-     solve-reflectRawQuotePattern unq (RUType univ) =-  do uH <- getNameFrom (sMN 0 "universe")-     claim uH (Var (reflm "Universe"))-     movelast uH-     fill $ reflCall "RUType" [Var uH]-     solve-     focus uH; fill (reflectUniverse univ); solve-reflectRawQuotePattern unq (RForce r) =-  do rH <- getNameFrom (sMN 0 "raw")-     claim rH (Var (reflm "Raw"))-     movelast rH-     fill $ reflCall "RForce" [Var rH]-     solve-     focus rH; reflectRawQuotePattern unq r-reflectRawQuotePattern unq (RConstant c) =-  do cH <- getNameFrom (sMN 0 "const")-     claim cH (Var (reflm "Constant"))-     movelast cH-     fill (reflCall "RConstant" [Var cH]); solve-     focus cH-     fill (reflectConstant c); solve--reflectBinderQuotePattern :: ([Name] -> a -> ElabD ()) -> [Name] -> Binder a -> ElabD ()-reflectBinderQuotePattern q unq (Lam t)-   = do t' <- claimTT (sMN 0 "ty"); movelast t'-        fill $ reflCall "Lam" [Var (reflm "TT"), Var t']-        solve-        focus t'; q unq t-reflectBinderQuotePattern q unq (Pi _ t k)-   = do t' <- claimTT (sMN 0 "ty") ; movelast t'-        k' <- claimTT (sMN 0 "k"); movelast k';-        fill $ reflCall "Pi" [Var (reflm "TT"), Var t', Var k']-        solve-        focus t'; q unq t-reflectBinderQuotePattern q unq (Let x y)-   = do x' <- claimTT (sMN 0 "ty"); movelast x';-        y' <- claimTT (sMN 0 "v"); movelast y';-        fill $ reflCall "Let" [Var (reflm "TT"), Var x', Var y']-        solve-        focus x'; q unq x-        focus y'; q unq y-reflectBinderQuotePattern q unq (NLet x y)-   = do x' <- claimTT (sMN 0 "ty"); movelast x'-        y' <- claimTT (sMN 0 "v"); movelast y'-        fill $ reflCall "NLet" [Var (reflm "TT"), Var x', Var y']-        solve-        focus x'; q unq x-        focus y'; q unq y-reflectBinderQuotePattern q unq (Hole t)-   = do t' <- claimTT (sMN 0 "ty"); movelast t'-        fill $ reflCall "Hole" [Var (reflm "TT"), Var t']-        solve-        focus t'; q unq t-reflectBinderQuotePattern q unq (GHole _ t)-   = do t' <- claimTT (sMN 0 "ty"); movelast t'-        fill $ reflCall "GHole" [Var (reflm "TT"), Var t']-        solve-        focus t'; q unq t-reflectBinderQuotePattern q unq (Guess x y)-   = do x' <- claimTT (sMN 0 "ty"); movelast x'-        y' <- claimTT (sMN 0 "v"); movelast y'-        fill $ reflCall "Guess" [Var (reflm "TT"), Var x', Var y']-        solve-        focus x'; q unq x-        focus y'; q unq y-reflectBinderQuotePattern q unq (PVar t)-   = do t' <- claimTT (sMN 0 "ty"); movelast t'-        fill $ reflCall "PVar" [Var (reflm "TT"), Var t']-        solve-        focus t'; q unq t-reflectBinderQuotePattern q unq (PVTy t)-   = do t' <- claimTT (sMN 0 "ty"); movelast t'-        fill $ reflCall "PVTy" [Var (reflm "TT"), Var t']-        solve-        focus t'; q unq t--reflectUniverse :: Universe -> Raw-reflectUniverse u =-  (Var (reflm (case u of-                 NullType -> "NullType"-                 UniqueType -> "UniqueType"-                 AllTypes -> "AllTypes")))---- | Create a reflected TT term, but leave refs to the provided name intact-reflectTTQuote :: [Name] -> Term -> Raw-reflectTTQuote unq (P nt n t)-  | n `elem` unq = Var n-  | otherwise = reflCall "P" [reflectNameType nt, reflectName n, reflectTTQuote unq t]-reflectTTQuote unq (V n)-  = reflCall "V" [RConstant (I n)]-reflectTTQuote unq (Bind n b x)-  = reflCall "Bind" [reflectName n, reflectBinderQuote reflectTTQuote (reflm "TT") unq b, reflectTTQuote unq x]-reflectTTQuote unq (App f x)-  = reflCall "App" [reflectTTQuote unq f, reflectTTQuote unq x]-reflectTTQuote unq (Constant c)-  = reflCall "TConst" [reflectConstant c]-reflectTTQuote unq (Proj t i)-  = reflCall "Proj" [reflectTTQuote unq t, RConstant (I i)]-reflectTTQuote unq (Erased) = Var (reflm "Erased")-reflectTTQuote unq (Impossible) = Var (reflm "Impossible")-reflectTTQuote unq (TType exp) = reflCall "TType" [reflectUExp exp]-reflectTTQuote unq (UType u) = reflCall "UType" [reflectUniverse u]--reflectRawQuote :: [Name] -> Raw -> Raw-reflectRawQuote unq (Var n)-  | n `elem` unq = Var n-  | otherwise = reflCall "Var" [reflectName n]-reflectRawQuote unq (RBind n b r) =-  reflCall "RBind" [reflectName n, reflectBinderQuote reflectRawQuote (reflm "Raw") unq b, reflectRawQuote unq r]-reflectRawQuote unq (RApp f x) =-  reflCall "RApp" [reflectRawQuote unq f, reflectRawQuote unq x]-reflectRawQuote unq RType = Var (reflm "RType")-reflectRawQuote unq (RUType u) =-  reflCall "RUType" [reflectUniverse u]-reflectRawQuote unq (RForce r) = reflCall "RForce" [reflectRawQuote unq r]-reflectRawQuote unq (RConstant cst) = reflCall "RConstant" [reflectConstant cst]--reflectNameType :: NameType -> Raw-reflectNameType (Bound) = Var (reflm "Bound")-reflectNameType (Ref) = Var (reflm "Ref")-reflectNameType (DCon x y _)-  = reflCall "DCon" [RConstant (I x), RConstant (I y)] -- FIXME: Uniqueness!-reflectNameType (TCon x y)-  = reflCall "TCon" [RConstant (I x), RConstant (I y)]--reflectName :: Name -> Raw-reflectName (UN s)-  = reflCall "UN" [RConstant (Str (str s))]-reflectName (NS n ns)-  = reflCall "NS" [ reflectName n-                  , foldr (\ n s ->-                             raw_apply ( Var $ sNS (sUN "::") ["List", "Prelude"] )-                                       [ RConstant StrType, RConstant (Str n), s ])-                             ( raw_apply ( Var $ sNS (sUN "Nil") ["List", "Prelude"] )-                                         [ RConstant StrType ])-                             (map str ns)-                  ]-reflectName (MN i 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---- | Elaborate a name to a pattern.  This means that NS and UN will be intact.--- MNs corresponding to will care about the string but not the number.  All--- others become _.-reflectNameQuotePattern :: Name -> ElabD ()-reflectNameQuotePattern n@(UN s)-  = do fill $ reflectName n-       solve-reflectNameQuotePattern n@(NS _ _)-  = do fill $ reflectName n-       solve-reflectNameQuotePattern (MN _ n)-  = do i <- getNameFrom (sMN 0 "mnCounter")-       claim i (RConstant (AType (ATInt ITNative)))-       movelast i-       fill $ reflCall "MN" [Var i, RConstant (Str $ T.unpack n)]-       solve-reflectNameQuotePattern _ -- for all other names, match any-  = do nameHole <- getNameFrom (sMN 0 "name")-       claim nameHole (Var (reflm "TTName"))-       movelast nameHole-       fill (Var nameHole)-       solve--reflectBinder :: Binder Term -> Raw-reflectBinder = reflectBinderQuote reflectTTQuote (reflm "TT") []--reflectBinderQuote :: ([Name] -> a -> Raw) -> Name -> [Name] -> Binder a -> Raw-reflectBinderQuote q ty unq (Lam t)-   = reflCall "Lam" [Var ty, q unq t]-reflectBinderQuote q ty unq (Pi _ t k)-   = reflCall "Pi" [Var ty, q unq t, q unq k]-reflectBinderQuote q ty unq (Let x y)-   = reflCall "Let" [Var ty, q unq x, q unq y]-reflectBinderQuote q ty unq (NLet x y)-   = reflCall "NLet" [Var ty, q unq x, q unq y]-reflectBinderQuote q ty unq (Hole t)-   = reflCall "Hole" [Var ty, q unq t]-reflectBinderQuote q ty unq (GHole _ t)-   = reflCall "GHole" [Var ty, q unq t]-reflectBinderQuote q ty unq (Guess x y)-   = reflCall "Guess" [Var ty, q unq x, q unq y]-reflectBinderQuote q ty unq (PVar t)-   = reflCall "PVar" [Var ty, q unq t]-reflectBinderQuote q ty unq (PVTy t)-   = reflCall "PVTy" [Var ty, q unq t]--mkList :: Raw -> [Raw] -> Raw-mkList ty []      = RApp (Var (sNS (sUN "Nil") ["List", "Prelude"])) ty-mkList ty (x:xs) = RApp (RApp (RApp (Var (sNS (sUN "::") ["List", "Prelude"])) ty)-                              x)-                        (mkList ty xs)--reflectConstant :: Const -> Raw-reflectConstant c@(I  _) = reflCall "I"  [RConstant c]-reflectConstant c@(BI _) = reflCall "BI" [RConstant c]-reflectConstant c@(Fl _) = reflCall "Fl" [RConstant c]-reflectConstant c@(Ch _) = reflCall "Ch" [RConstant c]-reflectConstant c@(Str _) = reflCall "Str" [RConstant c]-reflectConstant c@(B8 _) = reflCall "B8" [RConstant c]-reflectConstant c@(B16 _) = reflCall "B16" [RConstant c]-reflectConstant c@(B32 _) = reflCall "B32" [RConstant c]-reflectConstant c@(B64 _) = reflCall "B64" [RConstant c]-reflectConstant (B8V ws) = reflCall "B8V" [mkList (Var (sUN "Bits8")) . map (RConstant . B8) . V.toList $ ws]-reflectConstant (B16V ws) = reflCall "B8V" [mkList (Var (sUN "Bits16")) . map (RConstant . B16) . V.toList $ ws]-reflectConstant (B32V ws) = reflCall "B8V" [mkList (Var (sUN "Bits32")) . map (RConstant . B32) . V.toList $ ws]-reflectConstant (B64V ws) = reflCall "B8V" [mkList (Var (sUN "Bits64")) . map (RConstant . B64) . V.toList $ ws]-reflectConstant (AType (ATInt ITNative)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITNative")]]-reflectConstant (AType (ATInt ITBig)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITBig")]]-reflectConstant (AType ATFloat) = reflCall "AType" [Var (reflm "ATFloat")]-reflectConstant (AType (ATInt ITChar)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITChar")]]-reflectConstant StrType = Var (reflm "StrType")-reflectConstant (AType (ATInt (ITFixed IT8)))  = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT8")]]]-reflectConstant (AType (ATInt (ITFixed IT16))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT16")]]]-reflectConstant (AType (ATInt (ITFixed IT32))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT32")]]]-reflectConstant (AType (ATInt (ITFixed IT64))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT64")]]]-reflectConstant (AType (ATInt (ITVec IT8 c))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITVec" [Var (reflm "IT8"), RConstant (I c)]]]-reflectConstant (AType (ATInt (ITVec IT16 c))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITVec" [Var (reflm "IT16"), RConstant (I c)]]]-reflectConstant (AType (ATInt (ITVec IT32 c))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITVec" [Var (reflm "IT32"), RConstant (I c)]]]-reflectConstant (AType (ATInt (ITVec IT64 c))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITVec" [Var (reflm "IT64"), RConstant (I c)]]]-reflectConstant PtrType = Var (reflm "PtrType")-reflectConstant ManagedPtrType = Var (reflm "ManagedPtrType")-reflectConstant BufferType = Var (reflm "BufferType")-reflectConstant VoidType = Var (reflm "VoidType")-reflectConstant Forgot = Var (reflm "Forgot")-reflectConstant WorldType = Var (reflm "WorldType")-reflectConstant TheWorld = Var (reflm "TheWorld")--reflectUExp :: UExp -> Raw-reflectUExp (UVar i) = reflCall "UVar" [RConstant (I i)]-reflectUExp (UVal i) = reflCall "UVal" [RConstant (I i)]---- | Reflect the environment of a proof into a List (TTName, Binder TT)-reflectEnv :: Env -> Raw-reflectEnv = foldr consToEnvList emptyEnvList-  where-    consToEnvList :: (Name, Binder Term) -> Raw -> Raw-    consToEnvList (n, b) l-      = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"]))-                  [ envTupleType-                  , raw_apply (Var pairCon) [ (Var $ reflm "TTName")-                                            , (RApp (Var $ reflm "Binder")-                                                    (Var $ reflm "TT"))-                                            , reflectName n-                                            , reflectBinder b-                                            ]-                  , l-                  ]--    emptyEnvList :: Raw-    emptyEnvList = raw_apply (Var (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 $ 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 (WithFnType t) = raw_apply (Var $ reflErrName "WithFnType") [reflect t]-reflectErr (CantMatch t) = raw_apply (Var $ reflErrName "CantMatch") [reflect t]-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 (InvalidTCArg n t) = raw_apply (Var $ reflErrName "InvalidTCArg") [reflectName n, reflect t]-reflectErr (CantResolveAlts ss) =-  raw_apply (Var $ reflErrName "CantResolveAlts")-            [rawList (Var $ reflm "TTName") (map reflectName ss)]-reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]-reflectErr (NoEliminator str t) -  = raw_apply (Var $ reflErrName "NoEliminator") [RConstant (Str str),-                                                  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 (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]---- | Reflect a file context-reflectFC :: FC -> Raw-reflectFC fc = raw_apply (Var (reflm "FileLoc"))-                         [ RConstant (Str (fc_fname fc))-                         , raw_apply (Var pairCon) $-                             [intTy, intTy] ++-                             map (RConstant . I)-                                 [ fst (fc_start fc)-                                 , snd (fc_start fc)-                                 ]-                         , raw_apply (Var pairCon) $-                             [intTy, intTy] ++-                             map (RConstant . I)-                                 [ fst (fc_end fc)-                                 , snd (fc_end fc)-                                 ]-                         ]-  where intTy = RConstant (AType (ATInt ITNative))--elaboratingArgErr :: [(Name, Name)] -> Err -> Err-elaboratingArgErr [] err = err-elaboratingArgErr ((f,x):during) err = fromMaybe err (rewrite err)-  where rewrite (ElaboratingArg _ _ _ _) = Nothing-        rewrite (ProofSearchFail e) = fmap ProofSearchFail (rewrite e)-        rewrite (At fc e) = fmap (At fc) (rewrite e)-        rewrite err = Just (ElaboratingArg f x during err)---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-          -- At and Elaborating are just plumbing - error reflection shouldn't rewrite them-          handle e@(At fc err) = do logLvl 3 "Reflecting body of At"-                                    err' <- handle err-                                    return (At fc err')-          handle e@(Elaborating what n err) = do logLvl 3 "Reflecting body of Elaborating"-                                                 err' <- handle err-                                                 return (Elaborating what n err')-          handle e@(ElaboratingArg f a prev err) = do logLvl 3 "Reflecting body of ElaboratingArg"-                                                      hs <- getFnHandlers f a-                                                      err' <- if null hs-                                                                 then handle err-                                                                 else applyHandlers err hs-                                                      return (ElaboratingArg f a prev err')-          -- ProofSearchFail is an internal detail - so don't expose it-          handle (ProofSearchFail e) = handle e-          -- TODO: argument-specific error handlers go here for ElaboratingArg-          handle e = do ist <- getIState-                        logLvl 2 "Starting error reflection"-                        let handlers = idris_errorhandlers ist-                        applyHandlers e handlers-          getFnHandlers :: Name -> Name -> Idris [Name]-          getFnHandlers f arg = do ist <- getIState-                                   let funHandlers = maybe M.empty id .-                                                     lookupCtxtExact f .-                                                     idris_function_errorhandlers $ ist-                                   return . maybe [] S.toList . M.lookup arg $ funHandlers---          applyHandlers e handlers =-                      do ist <- getIState-                         let err = fmap (errReverse ist) e-                         logLvl 3 $ "Using reflection handlers " ++-                                    concat (intersperse ", " (map show handlers))-                         let reports = map (\n -> RApp (Var n) (reflectErr err)) 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 == reflm "TextPart" =-    Right (TextPart msg)-reifyReportPart (App (P (DCon _ _ _) n _) ttn)-  | n == reflm "NamePart" =-    case runElab initEState (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 == reflm "TermPart" =-  case runElab initEState (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 == reflm "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--reifyTyDecl :: Term -> ElabD RTyDecl-reifyTyDecl (App (App (App (P (DCon _ _ _) n _) tyN) args) ret)-  | n == tacN "Declare" =-  do tyN'  <- reifyTTName tyN-     args' <- case unList args of-                Nothing -> fail $ "Couldn't reify " ++ show args ++ " as an arglist."-                Just xs -> mapM reifyRArg xs-     ret'  <- reifyRaw ret-     return $ RDeclare tyN' args' ret'-  where reifyRArg :: Term -> ElabD RArg-        reifyRArg (App (App (P (DCon _ _ _) n _) argN) argTy)-          | n == tacN "Explicit"   = liftM2 RExplicit-                                            (reifyTTName argN)-                                            (reifyRaw argTy)-          | n == tacN "Implicit"   = liftM2 RImplicit-                                            (reifyTTName argN)-                                            (reifyRaw argTy)                               | n == tacN "Constraint" = liftM2 RConstraint-                                            (reifyTTName argN)-                                            (reifyRaw argTy)-        reifyRArg aTm = fail $ "Couldn't reify " ++ show aTm ++ " as an RArg."-reifyTyDecl tm = fail $ "Couldn't reify " ++ show tm ++ " as a type declaration."--envTupleType :: Raw-envTupleType-  = raw_apply (Var pairTy) [ (Var $ reflm "TTName")-                           , (RApp (Var $ reflm "Binder") (Var $ reflm "TT"))-                           ]--solveAll = try (do solve; solveAll) (return ())
src/Idris/Erasure.hs view
@@ -66,20 +66,19 @@ -- Perform usage analysis, write the relevant information in the internal -- structures, returning the list of reachable names. performUsageAnalysis :: [Name] -> Idris [Name]-performUsageAnalysis roots = do+performUsageAnalysis startNames = do     ctx <- tt_ctxt <$> getIState-    startNames <- getStartNames <$> getIState-     case startNames of-      Left reason -> return []  -- no main -> not compiling -> reachability irrelevant-      Right main  -> do+      [] -> return []  -- no main -> not compiling -> reachability irrelevant+      main  -> do         ci  <- idris_classes <$> getIState         cg  <- idris_callgraph <$> getIState         opt <- idris_optimisation <$> getIState         used <- idris_erasureUsed <$> getIState+        externs <- idris_externs <$> getIState          -- Build the dependency graph.-        let depMap = buildDepMap ci used ctx main+        let depMap = buildDepMap ci used (S.toList externs) ctx main          -- Search for reachable nodes in the graph.         let (residDeps, (reachableNames, minUse)) = minimalUsage depMap@@ -106,17 +105,6 @@          return $ S.toList reachableNames   where-    getStartNames :: IState -> Either Err [Name]-    getStartNames ist -       = case lookupCtxtName n (idris_implicits ist) of-              [(n', _)] -> Right (n' : roots)-              []        -> if null roots-                              then Left (NoSuchVariable n)-                              else Right roots-              more      -> Left (CantResolveAlts (map fst more))-      where-        n = sNS (sUN "main") ["Main"]-     indent = ("  " ++)      fmtItem :: (Cond, DepSet) -> String@@ -174,9 +162,10 @@  -- Build the dependency graph, -- starting the depth-first search from a list of Names.-buildDepMap :: Ctxt ClassInfo -> [(Name, Int)] -> Context -> [Name] -> Deps-buildDepMap ci used ctx startNames = addPostulates used $ -                                        dfs S.empty M.empty startNames+buildDepMap :: Ctxt ClassInfo -> [(Name, Int)] -> [(Name, Int)] ->+               Context -> [Name] -> Deps+buildDepMap ci used externs ctx startNames +    = addPostulates used $ dfs S.empty M.empty startNames   where     -- mark the result of Main.main as used with the empty assumption     addPostulates :: [(Name, Int)] -> Deps -> Deps@@ -226,6 +215,9 @@                 -- in general, all other primitives use all their arguments                 , [(n, Arg i) | (n,arity) <- usedPrims, i <- [0..arity-1]] +                -- %externs are assumed to use all their arguments+                , [(n, Arg i) | (n,arity) <- externs, i <- [0..arity-1]]+                 -- mkForeign* functions are special-cased below                 ]             ]@@ -287,7 +279,7 @@      etaExpand :: [Name] -> Term -> Term     etaExpand []       t = t-    etaExpand (n : ns) t = etaExpand ns (App t (P Ref n Erased))+    etaExpand (n : ns) t = etaExpand ns (App Complete t (P Ref n Erased))      getDepsSC :: Name -> [Name] -> Vars -> SC -> Deps     getDepsSC fn es vs  ImpossibleCase     = M.empty@@ -378,7 +370,7 @@         var t cd = getDepsTerm vs bs cd t      -- applications may add items to Cond-    getDepsTerm vs bs cd app@(App _ _)+    getDepsTerm vs bs cd app@(App _ _ _)         | (fun, args) <- unApply app = case fun of             -- instance constructors -> create metamethod deps             P (DCon _ _ _) ctorName@(SN (InstanceCtorN className)) _@@ -390,12 +382,11 @@             P (DCon _ _ _) n _ -> conditionalDeps n args  -- depends on whether (n,#) is used              -- mkForeign* calls must be special-cased because they are variadic-            -- All arguments must be marked as used, except for the first one,-            -- which is the (Foreign a) spec that defines the type-            -- and is not needed at runtime.+            -- All arguments must be marked as used, except for the first four,+            -- which define the call type and are not needed at runtime.             P _ (UN n) _-                | n `elem` map T.pack ["mkForeignPrim"]-                -> unconditionalDeps args -- (drop 1 args)+                | n == T.pack "mkForeignPrim"+                -> unconditionalDeps $ drop 4 args              -- a bound variable might draw in additional dependencies,             -- think: f x = x 0  <-- here, `x' _is_ used@@ -426,8 +417,8 @@             Bind n (Lam ty) t -> getDepsTerm vs bs cd (lamToLet [] app)              -- and we interpret applied lets as lambdas-            Bind n ( Let ty t') t -> getDepsTerm vs bs cd (App (Bind n (Lam ty) t) t')-            Bind n (NLet ty t') t -> getDepsTerm vs bs cd (App (Bind n (Lam ty) t) t')+            Bind n ( Let ty t') t -> getDepsTerm vs bs cd (App Complete (Bind n (Lam ty) t) t')+            Bind n (NLet ty t') t -> getDepsTerm vs bs cd (App Complete (Bind n (Lam ty) t) t')              Proj t i                 -> error $ "cannot[0] analyse projection !" ++ show i ++ " of " ++ show t@@ -501,9 +492,9 @@     -- convert applications of lambdas to lets     -- Note that this transformation preserves de bruijn numbering     lamToLet :: [Term] -> Term -> Term-    lamToLet    xs  (App f x)           = lamToLet (x:xs) f+    lamToLet    xs  (App _ f x)         = lamToLet (x:xs) f     lamToLet (x:xs) (Bind n (Lam ty) t) = Bind n (Let ty x) (lamToLet xs t)-    lamToLet (x:xs)  t                  = App (lamToLet xs t) x+    lamToLet (x:xs)  t                  = App Complete (lamToLet xs t) x     lamToLet    []   t                  = t      -- split "\x_i -> T(x_i)" into [x_i] and T
src/Idris/ErrReverse.hs view
@@ -35,9 +35,9 @@      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 (App s f a) = let f' = matchTerm ns l r f+                                       a' = matchTerm ns l r a in+                                       App s 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'@@ -54,16 +54,16 @@                         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)+    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 (App s f a) = App s (elideLambdas f) (elideLambdas a)     elideLambdas (Bind n (Lam t) sc)         | size sc > 200 = P Ref (sUN "...") Erased     elideLambdas (Bind n b sc)
src/Idris/Error.hs view
@@ -32,8 +32,9 @@              logLvl 7 $ "ALL CONSTRAINTS: " ++ show cs              when (not tit) $                    (tclift $ ucheck (idris_constraints ist)) `idrisCatch`-                              (\e -> do setErrSpan (getErrSpan e)-                                        iputStrLn (pshow ist e))+                              (\e -> do let fc = getErrSpan e+                                        setErrSpan fc+                                        iWarn fc $ pprintErr ist e)  showErr :: Err -> Idris String showErr e = getIState >>= return . flip pshow e@@ -67,6 +68,7 @@ tclift :: TC a -> Idris a tclift (OK v) = return v tclift (Error err@(At fc e)) = do setErrSpan fc; throwError err+tclift (Error err@(UniverseError fc _ _ _ _)) = do setErrSpan fc; throwError err tclift (Error err) = throwError err  tctry :: TC a -> TC a -> Idris a@@ -77,6 +79,7 @@  getErrSpan :: Err -> FC getErrSpan (At fc _) = fc+getErrSpan (UniverseError fc _ _ _ _) = fc getErrSpan _ = emptyFC  --------------------------------------------------------------------@@ -88,9 +91,9 @@ warnDisamb ist (PRef _ _) = return () warnDisamb ist (PInferRef _ _) = return () warnDisamb ist (PPatvar _ _) = return ()-warnDisamb ist (PLam _ _ t b) = warnDisamb ist t >> warnDisamb ist b-warnDisamb ist (PPi _ _ t b) = warnDisamb ist t >> warnDisamb ist b-warnDisamb ist (PLet _ _ x t b) = warnDisamb ist x >> warnDisamb ist t >> warnDisamb ist b+warnDisamb ist (PLam _ _ _ t b) = warnDisamb ist t >> warnDisamb ist b+warnDisamb ist (PPi _ _ _ t b) = warnDisamb ist t >> warnDisamb ist b+warnDisamb ist (PLet _ _ _ x t b) = warnDisamb ist x >> warnDisamb ist t >> warnDisamb ist b warnDisamb ist (PTyped x t) = warnDisamb ist x >> warnDisamb ist t warnDisamb ist (PApp _ t args) = warnDisamb ist t >>                                  mapM_ (warnDisamb ist . getTm) args@@ -99,32 +102,30 @@ warnDisamb ist (PMatchApp _ _) = return () warnDisamb ist (PCase _ tm cases) = warnDisamb ist tm >>                                     mapM_ (\(x,y)-> warnDisamb ist x >> warnDisamb ist y) cases+warnDisamb ist (PIfThenElse _ c t f) = mapM_ (warnDisamb ist) [c, t, f] warnDisamb ist (PTrue _ _) = return ()-warnDisamb ist (PRefl _ tm) = warnDisamb ist tm warnDisamb ist (PResolveTC _) = return ()-warnDisamb ist (PEq _ a b x y) = warnDisamb ist a >> warnDisamb ist b >>-                                 warnDisamb ist x >> warnDisamb ist y warnDisamb ist (PRewrite _ x y z) = warnDisamb ist x >> warnDisamb ist y >>                                     Foldable.mapM_ (warnDisamb ist) z warnDisamb ist (PPair _ _ x y) = warnDisamb ist x >> warnDisamb ist y warnDisamb ist (PDPair _ _ x y z) = warnDisamb ist x >> warnDisamb ist y >> warnDisamb ist z warnDisamb ist (PAlternative _ tms) = mapM_ (warnDisamb ist) tms warnDisamb ist (PHidden tm) = warnDisamb ist tm-warnDisamb ist PType = return ()+warnDisamb ist (PType _) = return () warnDisamb ist (PUniverse _) = return () warnDisamb ist (PGoal _ x _ y) = warnDisamb ist x >> warnDisamb ist y-warnDisamb ist (PConstant _) = return ()+warnDisamb ist (PConstant _ _) = return () warnDisamb ist Placeholder = return () warnDisamb ist (PDoBlock steps) = mapM_ wStep steps   where wStep (DoExp _ x) = warnDisamb ist x-        wStep (DoBind _ _ x) = warnDisamb ist x+        wStep (DoBind _ _ _ x) = warnDisamb ist x         wStep (DoBindP _ x y cs) = warnDisamb ist x >> warnDisamb ist y >>-                                   mapM_ (\(x,y)-> warnDisamb ist x >> warnDisamb ist y) cs-        wStep (DoLet _ _ x y) = warnDisamb ist x >> warnDisamb ist y+                                   mapM_ (\(x,y) -> warnDisamb ist x >> warnDisamb ist y) cs+        wStep (DoLet _ _ _ x y) = warnDisamb ist x >> warnDisamb ist y         wStep (DoLetP _ x y) = warnDisamb ist x >> warnDisamb ist y warnDisamb ist (PIdiom _ x) = warnDisamb ist x warnDisamb ist (PReturn _) = return ()-warnDisamb ist (PMetavar _) = return ()+warnDisamb ist (PMetavar _ _) = return () warnDisamb ist (PProof tacs) = mapM_ (Foldable.mapM_ (warnDisamb ist)) tacs warnDisamb ist (PTactics tacs) = mapM_ (Foldable.mapM_ (warnDisamb ist)) tacs warnDisamb ist (PElabError _) = return ()@@ -133,7 +134,7 @@ warnDisamb ist (PDisamb ds tm) = warnDisamb ist tm >>                                  mapM_ warnEmpty ds   where warnEmpty d =-          when (null (filter (isIn d . fst) (ctxtAlist (tt_ctxt ist)))) $+          when (not (any (isIn d . fst) (ctxtAlist (tt_ctxt ist)))) $             ierror . Msg $               "Nothing found in namespace \"" ++               intercalate "." (map T.unpack d) ++@@ -146,6 +147,7 @@ warnDisamb ist (PQuasiquote tm goal) = warnDisamb ist tm >>                                        Foldable.mapM_ (warnDisamb ist) goal warnDisamb ist (PUnquote tm) = warnDisamb ist tm+warnDisamb ist (PQuoteName _) = return () warnDisamb ist (PAs _ _ tm) = warnDisamb ist tm warnDisamb ist (PAppImpl tm _) = warnDisamb ist tm-warnDisamb ist (PRunTactics _ tm) = warnDisamb ist tm+warnDisamb ist (PRunElab _ tm) = warnDisamb ist tm
src/Idris/IBC.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} -module Idris.IBC where+module Idris.IBC (loadIBC, loadPkgIndex,+                  writeIBC, writePkgIndex) where  import Idris.Core.Evaluate import Idris.Core.TT@@ -21,8 +22,10 @@ import qualified Cheapskate.Types as CT  import Data.Binary+import Data.Functor import Data.Vector.Binary-import Data.List+import Data.List as L+import Data.Maybe (catMaybes) import Data.ByteString.Lazy as B hiding (length, elem, map) import qualified Data.Text as T import qualified Data.Set as S@@ -34,12 +37,13 @@ import System.FilePath import System.Directory import Codec.Compression.Zlib (compress)+import Codec.Archive.Zip import Util.Zlib (decompressEither) -ibcVersion :: Word8-ibcVersion = 101+ibcVersion :: Word16+ibcVersion = 110 -data IBCFile = IBCFile { ver :: Word8,+data IBCFile = IBCFile { ver :: Word16,                          sourcefile :: FilePath,                          symbols :: ![Name],                          ibc_imports :: ![(Bool, FilePath)],@@ -48,7 +52,7 @@                          ibc_fixes :: ![FixDecl],                          ibc_statics :: ![(Name, [Bool])],                          ibc_classes :: ![(Name, ClassInfo)],-                         ibc_instances :: ![(Bool, Name, Name)],+                         ibc_instances :: ![(Bool, Bool, Name, Name)],                          ibc_dsls :: ![(Name, DSL)],                          ibc_datatypes :: ![(Name, TypeInfo)],                          ibc_optimise :: ![(Name, OptInfo)],@@ -79,9 +83,11 @@                          ibc_metavars :: ![(Name, (Maybe Name, Int, Bool))],                          ibc_patdefs :: ![(Name, ([([Name], Term, Term)], [PTerm]))],                          ibc_postulates :: ![Name],+                         ibc_externs :: ![(Name, Int)],                          ibc_parsedSpan :: !(Maybe FC),                          ibc_usage :: ![(Name, Int)],-                         ibc_exports :: ![Name]+                         ibc_exports :: ![Name],+                         ibc_autohints :: ![(Name, Name)]                        }    deriving Show {-!@@ -89,7 +95,7 @@ !-}  initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] []+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] []  loadIBC :: Bool -- ^ True = reexport, False = make everything private         -> FilePath -> Idris ()@@ -100,9 +106,12 @@                                 Just p -> not p && reexport                 when redo $                   do iLOG $ "Loading ibc " ++ fp ++ " " ++ show reexport-                     ibcf <- runIO $ (bdecode fp :: IO IBCFile)-                     process reexport ibcf fp-                     addImported reexport fp+                     archiveFile <- runIO $ B.readFile fp+                     case toArchiveOrFail archiveFile of+                        Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"+                                          ++ "Please clean and rebuild it."+                        Right archive -> do process reexport archive fp+                                            addImported reexport fp  -- | Load an entire package from its index file loadPkgIndex :: String -> Idris ()@@ -111,16 +120,64 @@                       fp <- findPkgIndex pkg                       loadIBC True fp -bencode :: Binary a => FilePath -> a -> IO ()-bencode f d = B.writeFile f (compress (encode d)) -bdecode :: Binary b => FilePath -> IO b-bdecode f = do d' <- B.readFile f-               either-                 (\(_, e) -> error $ "Invalid / corrupted zip format on " ++ show f ++ ": " ++ e)-                 (return . decode)-                 (decompressEither d')+makeEntry :: (Binary b) => String -> [b] -> Maybe Entry+makeEntry name val = if L.null val+                        then Nothing+                        else Just $ toEntry name 0 (encode val) ++entries :: IBCFile -> [Entry]+entries i = catMaybes [Just $ toEntry "ver" 0 (encode $ ver i),+                       makeEntry "sourcefile"  (sourcefile i),+                       makeEntry "symbols"  (symbols i),+                       makeEntry "ibc_imports"  (ibc_imports i),+                       makeEntry "ibc_importdirs"  (ibc_importdirs i),+                       makeEntry "ibc_implicits"  (ibc_implicits i),+                       makeEntry "ibc_fixes"  (ibc_fixes i),+                       makeEntry "ibc_statics"  (ibc_statics i),+                       makeEntry "ibc_classes"  (ibc_classes i),+                       makeEntry "ibc_instances"  (ibc_instances i),+                       makeEntry "ibc_dsls"  (ibc_dsls i),+                       makeEntry "ibc_datatypes"  (ibc_datatypes i),+                       makeEntry "ibc_optimise"  (ibc_optimise i),+                       makeEntry "ibc_syntax"  (ibc_syntax i),+                       makeEntry "ibc_keywords"  (ibc_keywords i),+                       makeEntry "ibc_objs"  (ibc_objs i),+                       makeEntry "ibc_libs"  (ibc_libs i),+                       makeEntry "ibc_cgflags"  (ibc_cgflags i),+                       makeEntry "ibc_dynamic_libs"  (ibc_dynamic_libs i),+                       makeEntry "ibc_hdrs"  (ibc_hdrs i),+                       makeEntry "ibc_access"  (ibc_access i),+                       makeEntry "ibc_total"  (ibc_total i),+                       makeEntry "ibc_totcheckfail"  (ibc_totcheckfail i),+                       makeEntry "ibc_flags"  (ibc_flags i),+                       makeEntry "ibc_fninfo"  (ibc_fninfo i),+                       makeEntry "ibc_cg"  (ibc_cg i),+                       makeEntry "ibc_defs"  (ibc_defs i),+                       makeEntry "ibc_docstrings"  (ibc_docstrings i),+                       makeEntry "ibc_moduledocs"  (ibc_moduledocs i),+                       makeEntry "ibc_transforms"  (ibc_transforms i),+                       makeEntry "ibc_errRev"  (ibc_errRev i),+                       makeEntry "ibc_coercions"  (ibc_coercions i),+                       makeEntry "ibc_lineapps"  (ibc_lineapps i),+                       makeEntry "ibc_namehints"  (ibc_namehints i),+                       makeEntry "ibc_metainformation"  (ibc_metainformation i),+                       makeEntry "ibc_errorhandlers"  (ibc_errorhandlers i),+                       makeEntry "ibc_function_errorhandlers"  (ibc_function_errorhandlers i),+                       makeEntry "ibc_metavars"  (ibc_metavars i),+                       makeEntry "ibc_patdefs"  (ibc_patdefs i),+                       makeEntry "ibc_postulates"  (ibc_postulates i),+                       makeEntry "ibc_externs"  (ibc_externs i),+                       toEntry "ibc_parsedSpan" 0 . encode <$> ibc_parsedSpan i,+                       makeEntry "ibc_usage"  (ibc_usage i),+                       makeEntry "ibc_exports"  (ibc_exports i),+                       makeEntry "ibc_autohints"  (ibc_autohints i)]++writeArchive :: FilePath -> IBCFile -> Idris ()+writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArchive (entries i)+                       runIO $ B.writeFile fp (fromArchive a)+ writeIBC :: FilePath -> FilePath -> Idris () writeIBC src f     = do iLOG $ "Writing ibc " ++ show f@@ -131,7 +188,7 @@          resetNameIdx          ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })          idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)-                        runIO $ bencode f ibcf+                        writeArchive f ibcf                         iLOG "Written")             (\c -> do iLOG $ "Failed " ++ pshow i c)          return ()@@ -147,7 +204,7 @@          resetNameIdx          let ibcf = initIBC { ibc_imports = imps }          idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)-                        runIO $ bencode f ibcf+                        writeArchive f ibcf                         iLOG "Written")             (\c -> do iLOG $ "Failed " ++ pshow i c)          return ()@@ -155,7 +212,7 @@ mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile mkIBC [] f = return f mkIBC (i:is) f = do ist <- getIState-                    logLvl 5 $ show i ++ " " ++ show (Data.List.length is)+                    logLvl 5 $ show i ++ " " ++ show (L.length is)                     f' <- ibc ist i f                     mkIBC is f' @@ -172,8 +229,8 @@                    = case lookupCtxtExact n (idris_classes i) of                         Just v -> return f { ibc_classes = (n,v): ibc_classes f     }                         _ -> ifail "IBC write failed"-ibc i (IBCInstance int n ins) f-                   = return f { ibc_instances = (int,n,ins): ibc_instances f     }+ibc i (IBCInstance int res n ins) f+                   = return f { ibc_instances = (int, res, n, ins) : ibc_instances f } ibc i (IBCDSL n) f                    = case lookupCtxtExact n (idris_dsls i) of                         Just v -> return f { ibc_dsls = (n,v): ibc_dsls f     }@@ -228,6 +285,7 @@           Nothing -> return f           Just t -> return f { ibc_metavars = (n, t) : ibc_metavars f } ibc i (IBCPostulate n) f = return f { ibc_postulates = n : ibc_postulates f }+ibc i (IBCExtern n) f = return f { ibc_externs = n : ibc_externs f } ibc i (IBCTotCheckErr fc err) f = return f { ibc_totcheckfail = (fc, err) : ibc_totcheckfail f } ibc i (IBCParsedRegion fc) f = return f { ibc_parsedSpan = Just fc } ibc i (IBCModDocs n) f = case lookupCtxtExact n (idris_moduledocs i) of@@ -235,64 +293,70 @@                            _ -> ifail "IBC write failed" ibc i (IBCUsage n) f = return f { ibc_usage = n : ibc_usage f } ibc i (IBCExport n) f = return f { ibc_exports = n : ibc_exports f }+ibc i (IBCAutoHint n h) f = return f { ibc_autohints = (n, h) : ibc_autohints f } -process :: Bool -- ^ Reexporting-           -> IBCFile -> FilePath -> Idris ()-process reexp i fn-   | ver i /= ibcVersion-       = do iLOG "ibc out of date"-            let e = if ver i < ibcVersion then " an earlier " else " a later "-            ifail $ "Incompatible ibc version.\nThis library was built with"-                    ++ e ++ "version of Idris.\n" ++-                    "Please clean and rebuild."+getEntry :: (Binary b, NFData b) => b -> FilePath -> Archive -> Idris b+getEntry alt f a = case findEntryByPath f a of+                Nothing -> return alt+                Just e -> return $ (force . decode . fromEntry) e -                              --- please rebuild"-   | otherwise =-            do srcok <- runIO $ doesFileExist (sourcefile i)-               when srcok $ timestampOlder (sourcefile i) fn-               v <- verbose-               quiet <- getQuiet---                when (v && srcok && not quiet) $ iputStrLn $ "Skipping " ++ sourcefile i-               pImportDirs $ force (ibc_importdirs i)-               pImports $ force (ibc_imports i)-               pImps $ force (ibc_implicits i)-               pFixes $ force (ibc_fixes i)-               pStatics $ force (ibc_statics i)-               pClasses $ force (ibc_classes i)-               pInstances $ force (ibc_instances i)-               pDSLs $ force (ibc_dsls i)-               pDatatypes $ force (ibc_datatypes i)-               pOptimise $ force (ibc_optimise i)-               pSyntax $ force (ibc_syntax i)-               pKeywords $ force (ibc_keywords i)-               pObjs $ force (ibc_objs i)-               pLibs $ force (ibc_libs i)-               pCGFlags $ force (ibc_cgflags i)-               pDyLibs $ force (ibc_dynamic_libs i)-               pHdrs $ force (ibc_hdrs i)-               pDefs reexp (symbols i) $ force (ibc_defs i)-               pPatdefs $ force (ibc_patdefs i)-               pAccess reexp $ force (ibc_access i)-               pFlags $ force (ibc_flags i)-               pFnInfo $ force (ibc_fninfo i)-               pTotal $ force (ibc_total i)-               pTotCheckErr $ force (ibc_totcheckfail i)-               pCG $ force (ibc_cg i)-               pDocs $ force (ibc_docstrings i)-               pMDocs $ force (ibc_moduledocs i)-               pCoercions $ force (ibc_coercions i)-               pTrans $ force (ibc_transforms i)-               pErrRev $ force (ibc_errRev i)-               pLineApps $ force (ibc_lineapps i)-               pNameHints $ force (ibc_namehints i)-               pMetaInformation $ force (ibc_metainformation i)-               pErrorHandlers $ force (ibc_errorhandlers i)-               pFunctionErrorHandlers $ force (ibc_function_errorhandlers i)-               pMetavars $ force (ibc_metavars i)-               pPostulates $ force (ibc_postulates i)-               pParsedSpan $ force (ibc_parsedSpan i)-               pUsage $ force (ibc_usage i)-               pExports $ force (ibc_exports i)+process :: Bool -- ^ Reexporting+           -> Archive -> FilePath -> Idris ()+process reexp i fn = do+                ver <- getEntry 0 "ver" i+                when (ver /= ibcVersion) $ do+                                    iLOG "ibc out of date"+                                    let e = if ver < ibcVersion+                                            then " an earlier " else " a later "+                                    ifail $ "Incompatible ibc version.\nThis library was built with"+                                            ++ e ++ "version of Idris.\n" ++ "Please clean and rebuild."+                source <- getEntry "" "sourcefile" i+                srcok <- runIO $ doesFileExist source+                when srcok $ timestampOlder source fn+                pImportDirs =<< getEntry [] "ibc_importdirs" i+                pImports =<< getEntry [] "ibc_imports" i+                pImps =<< getEntry [] "ibc_implicits" i+                pFixes =<< getEntry [] "ibc_fixes" i+                pStatics =<< getEntry [] "ibc_statics" i+                pClasses =<< getEntry [] "ibc_classes" i+                pInstances =<< getEntry [] "ibc_instances" i+                pDSLs =<< getEntry [] "ibc_dsls" i+                pDatatypes =<< getEntry [] "ibc_datatypes" i+                pOptimise =<< getEntry [] "ibc_optimise" i+                pSyntax =<< getEntry [] "ibc_syntax" i+                pKeywords =<< getEntry [] "ibc_keywords" i+                pObjs =<< getEntry [] "ibc_objs" i+                pLibs =<< getEntry [] "ibc_libs" i+                pCGFlags =<< getEntry [] "ibc_cgflags" i+                pDyLibs =<< getEntry [] "ibc_dynamic_libs" i+                pHdrs =<< getEntry [] "ibc_hdrs" i+                symbols <- getEntry [] "symbols" i+                defs <- getEntry [] "ibc_defs" i+                pDefs reexp symbols defs+                pPatdefs =<< getEntry [] "ibc_patdefs" i+                pAccess reexp =<< getEntry [] "ibc_access" i+                pFlags =<< getEntry [] "ibc_flags" i+                pFnInfo =<< getEntry [] "ibc_fninfo" i+                pTotal =<< getEntry [] "ibc_total" i+                pTotCheckErr =<< getEntry [] "ibc_totcheckfail" i+                pCG =<< getEntry [] "ibc_cg" i+                pDocs =<< getEntry [] "ibc_docstrings" i+                pMDocs =<< getEntry [] "ibc_moduledocs" i+                pCoercions =<< getEntry [] "ibc_coercions" i+                pTrans =<< getEntry [] "ibc_transforms" i+                pErrRev =<< getEntry [] "ibc_errRev" i+                pLineApps =<< getEntry [] "ibc_lineapps" i+                pNameHints =<< getEntry [] "ibc_namehints" i+                pMetaInformation =<< getEntry [] "ibc_metainformation" i+                pErrorHandlers =<< getEntry [] "ibc_errorhandlers" i+                pFunctionErrorHandlers =<< getEntry [] "ibc_function_errorhandlers" i+                pMetavars =<< getEntry [] "ibc_metavars" i+                pPostulates =<< getEntry [] "ibc_postulates" i+                pExterns =<< getEntry [] "ibc_externs" i+                pParsedSpan =<< getEntry Nothing "ibc_parsedSpan" i+                pUsage =<< getEntry [] "ibc_usage" i+                pExports =<< getEntry [] "ibc_exports" i+                pAutoHints =<< getEntry [] "ibc_autohints" i  timestampOlder :: FilePath -> FilePath -> Idris () timestampOlder src ibc = do srct <- runIO $ getModificationTime src@@ -302,22 +366,24 @@                                else return ()  pPostulates :: [Name] -> Idris ()-pPostulates ns = do-    i <- getIState-    putIState i{ idris_postulates = idris_postulates i `S.union` S.fromList ns }+pPostulates ns = updateIState+                    (\i -> i { idris_postulates = idris_postulates i `S.union` S.fromList ns }) +pExterns :: [(Name, Int)] -> Idris ()+pExterns ns = updateIState (\i -> i{ idris_externs = idris_externs i `S.union` S.fromList ns })+ pParsedSpan :: Maybe FC -> Idris ()-pParsedSpan fc = do ist <- getIState-                    putIState ist { idris_parsedSpan = fc }+pParsedSpan fc = updateIState (\i -> i { idris_parsedSpan = fc })  pUsage :: [(Name, Int)] -> Idris ()-pUsage ns = do ist <- getIState-               putIState ist { idris_erasureUsed = ns ++ idris_erasureUsed ist }+pUsage ns = updateIState (\i -> i { idris_erasureUsed = ns ++ idris_erasureUsed i })  pExports :: [Name] -> Idris ()-pExports ns = do ist <- getIState-                 putIState ist { idris_exports = ns ++ idris_exports ist }+pExports ns = updateIState (\i -> i { idris_exports = ns ++ idris_exports i }) +pAutoHints :: [(Name, Name)] -> Idris ()+pAutoHints ns = mapM_ (\(n,h) -> addAutoHint n h) ns+ pImportDirs :: [FilePath] -> Idris () pImportDirs fs = mapM_ addImportDir fs @@ -373,37 +439,26 @@                                            = addDef n c' (idris_classes i) }))                     cs -pInstances :: [(Bool, Name, Name)] -> Idris ()-pInstances cs = mapM_ (\ (i, n, ins) -> addInstance i n ins) cs+pInstances :: [(Bool, Bool, Name, Name)] -> Idris ()+pInstances cs = mapM_ (\ (i, res, n, ins) -> addInstance i res n ins) cs  pDSLs :: [(Name, DSL)] -> Idris ()-pDSLs cs = mapM_ (\ (n, c) ->-                        do i <- getIState-                           putIState (i { idris_dsls-                                           = addDef n c (idris_dsls i) }))-                    cs+pDSLs cs = mapM_ (\ (n, c) -> updateIState (\i ->+                        i { idris_dsls = addDef n c (idris_dsls i) })) cs  pDatatypes :: [(Name, TypeInfo)] -> Idris ()-pDatatypes cs = mapM_ (\ (n, c) ->-                        do i <- getIState-                           putIState (i { idris_datatypes-                                           = addDef n c (idris_datatypes i) }))-                    cs+pDatatypes cs = mapM_ (\ (n, c) -> updateIState (\i ->+                        i { idris_datatypes = addDef n c (idris_datatypes i) })) cs  pOptimise :: [(Name, OptInfo)] -> Idris ()-pOptimise cs = mapM_ (\ (n, c) ->-                        do i <- getIState-                           putIState (i { idris_optimisation-                                           = addDef n c (idris_optimisation i) }))-                    cs+pOptimise cs = mapM_ (\ (n, c) -> updateIState (\i ->+                        i { idris_optimisation = addDef n c (idris_optimisation i) })) cs  pSyntax :: [Syntax] -> Idris ()-pSyntax s = do i <- getIState-               putIState (i { syntax_rules = updateSyntaxRules s (syntax_rules i) })+pSyntax s = updateIState (\i -> i { syntax_rules = updateSyntaxRules s (syntax_rules i) })  pKeywords :: [String] -> Idris ()-pKeywords k = do i <- getIState-                 putIState (i { syntax_keywords = k ++ syntax_keywords i })+pKeywords k = updateIState (\i -> i { syntax_keywords = k ++ syntax_keywords i })  pObjs :: [(Codegen, FilePath)] -> Idris () pObjs os = mapM_ (\ (cg, obj) -> do dirs <- allImportDirs@@ -427,11 +482,8 @@ pHdrs hs = mapM_ (uncurry addHdr) hs  pPatdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))] -> Idris ()-pPatdefs ds-   = mapM_ (\ (n, d) ->-                do i <- getIState-                   putIState (i { idris_patdefs = addDef n (force d) (idris_patdefs i) }))-           ds+pPatdefs ds = mapM_ (\ (n, d) -> updateIState (\i ->+            i { idris_patdefs = addDef n (force d) (idris_patdefs i) })) ds  pDefs :: Bool -> [Name] -> [(Name, Def)] -> Idris () pDefs reexp syms ds@@ -441,9 +493,8 @@                        TyDecl _ _ -> return ()                        _ -> do iLOG $ "SOLVING " ++ show n                                solveDeferred n-                  i <- getIState+                  updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) }) --                   logLvl 1 $ "Added " ++ show (n, d')-                  putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })                   if (not reexp) then do iLOG $ "Not exporting " ++ show n                                          setAccessibility n Hidden                                  else iLOG $ "Exporting " ++ show n) ds@@ -487,7 +538,7 @@      update (P t n ty) = do n' <- getSymbol n                            return $ P t n' ty-    update (App f a) = liftM2 App (update f) (update a)+    update (App s f a) = liftM2 (App s) (update f) (update a)     update (Bind n b sc) = do b' <- updateB b                               sc' <- update sc                               return $ Bind n b' sc'@@ -503,9 +554,8 @@ pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds  pMDocs :: [(Name, Docstring D.DocTerm)] -> Idris ()-pMDocs ds = mapM_ addMDocStr ds-  where addMDocStr (n, d) = do ist <- getIState-                               putIState ist { idris_moduledocs = addDef n d (idris_moduledocs ist) }+pMDocs ds = mapM_  (\ (n, d) -> updateIState (\i ->+            i { idris_moduledocs = addDef n d (idris_moduledocs i) })) ds  pAccess :: Bool -- ^ Reexporting?            -> [(Name, Accessibility)] -> Idris ()@@ -513,9 +563,7 @@         = mapM_ (\ (n, a_in) ->                       do let a = if reexp then a_in else Hidden                          logLvl 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a-                         i <- getIState-                         putIState (i { tt_ctxt = setAccess n a (tt_ctxt i) }))-                   ds+                         updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })) ds  pFlags :: [(Name, [FnOpt])] -> Idris () pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds@@ -524,14 +572,10 @@ pFnInfo ds = mapM_ (\ (n, a) -> setFnInfo n a) ds  pTotal :: [(Name, Totality)] -> Idris ()-pTotal ds = mapM_ (\ (n, a) ->-                      do i <- getIState-                         putIState (i { tt_ctxt = setTotal n a (tt_ctxt i) }))-                   ds+pTotal ds = mapM_ (\ (n, a) -> updateIState (\i -> i { tt_ctxt = setTotal n a (tt_ctxt i) })) ds  pTotCheckErr :: [(FC, String)] -> Idris ()-pTotCheckErr es = do ist <- getIState-                     putIState ist { idris_totcheckfail = idris_totcheckfail ist ++ es }+pTotCheckErr es = updateIState (\i -> i { idris_totcheckfail = idris_totcheckfail i ++ es })  pCG :: [(Name, CGInfo)] -> Idris () pCG ds = mapM_ (\ (n, a) -> addToCG n a) ds@@ -552,24 +596,19 @@ pNameHints ns = mapM_ (\ (n, ty) -> addNameHint n ty) ns  pMetaInformation :: [(Name, MetaInformation)] -> Idris ()-pMetaInformation ds = mapM_ (\ (n, m) ->-                            do i <- getIState-                               putIState (i { tt_ctxt = setMetaInformation n m (tt_ctxt i) }))-                         ds+pMetaInformation ds = mapM_ (\ (n, m) -> updateIState (\i ->+                               i { tt_ctxt = setMetaInformation n m (tt_ctxt i) })) ds  pErrorHandlers :: [Name] -> Idris ()-pErrorHandlers ns = do i <- getIState-                       putIState $ i { idris_errorhandlers = idris_errorhandlers i ++ ns }+pErrorHandlers ns = updateIState (\i ->+                        i { idris_errorhandlers = idris_errorhandlers i ++ ns })  pFunctionErrorHandlers :: [(Name, Name, Name)] -> Idris ()-pFunctionErrorHandlers [] = return ()-pFunctionErrorHandlers ((fn, arg, handler):ns) = do addFunctionErrorHandlers fn arg [handler]-                                                    pFunctionErrorHandlers ns+pFunctionErrorHandlers ns =  mapM_ (\ (fn,arg,handler) ->+                                addFunctionErrorHandlers fn arg [handler]) ns  pMetavars :: [(Name, (Maybe Name, Int, Bool))] -> Idris ()-pMetavars ns = do i <- getIState-                  putIState $ i { idris_metavars = Data.List.reverse ns-                                                     ++ idris_metavars i }+pMetavars ns = updateIState (\i -> i { idris_metavars = L.reverse ns ++ idris_metavars i })  ----- For Cheapskate and docstrings @@ -933,101 +972,6 @@                      return (DataMI x1)              _ -> error "Corrupted binary data for MetaInformation" -instance Binary IBCFile where-        put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43)-         = {-# SCC "putIBCFile" #-}-            do put x1-               put x2-               put x3-               put x4-               put x5-               put x6-               put x7-               put x8-               put x9-               put x10-               put x11-               put x12-               put x13-               put x14-               put x15-               put x16-               put x17-               put x18-               put x19-               put x20-               put x21-               put x22-               put x23-               put x24-               put x25-               put x26-               put x27-               put x28-               put x29-               put x30-               put x31-               put x32-               put x33-               put x34-               put x35-               put x36-               put x37-               put x38-               put x39-               put x40-               put x41-               put x42-               put x43--        get-          = do x1 <- get-               if x1 == ibcVersion then-                 do x2 <- get-                    x3 <- get-                    x4 <- get-                    x5 <- get-                    x6 <- get-                    x7 <- get-                    x8 <- get-                    x9 <- get-                    x10 <- get-                    x11 <- get-                    x12 <- get-                    x13 <- get-                    x14 <- get-                    x15 <- get-                    x16 <- get-                    x17 <- get-                    x18 <- get-                    x19 <- get-                    x20 <- get-                    x21 <- get-                    x22 <- get-                    x23 <- get-                    x24 <- get-                    x25 <- get-                    x26 <- get-                    x27 <- get-                    x28 <- get-                    x29 <- get-                    x30 <- get-                    x31 <- get-                    x32 <- get-                    x33 <- get-                    x34 <- get-                    x35 <- get-                    x36 <- get-                    x37 <- get-                    x38 <- get-                    x39 <- get-                    x40 <- get-                    x41 <- get-                    x42 <- get-                    x43 <- get-                    return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43)-                  else return (initIBC { ver = x1 })- instance Binary DataOpt where   put x = case x of     Codata -> putWord8 0@@ -1062,6 +1006,7 @@                 Constructor -> putWord8 13                 CExport x1 -> do putWord8 14                                  put x1+                AutoHint -> putWord8 15         get           = do i <- getWord8                case i of@@ -1082,6 +1027,7 @@                    13 -> return Constructor                    14 -> do x1 <- get                             return $ CExport x1+                   15 -> return AutoHint                    _ -> error "Corrupted binary data for FnOpt"  instance Binary Fixity where@@ -1198,7 +1144,7 @@                                     put x1                                     put x2                                     put x3-                PTy x1 x2 x3 x4 x5 x6 x7+                PTy x1 x2 x3 x4 x5 x6 x7 x8                                    -> do putWord8 1                                          put x1                                          put x2@@ -1207,6 +1153,7 @@                                          put x5                                          put x6                                          put x7+                                         put x8                 PClauses x1 x2 x3 x4 -> do putWord8 2                                            put x1                                            put x2@@ -1224,10 +1171,11 @@                                        put x1                                        put x2                                        put x3-                PNamespace x1 x2 -> do putWord8 5-                                       put x1-                                       put x2-                PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 ->+                PNamespace x1 x2 x3 -> do putWord8 5+                                          put x1+                                          put x2+                                          put x3+                PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 ->                                              do putWord8 6                                                 put x1                                                 put x2@@ -1238,7 +1186,10 @@                                                 put x7                                                 put x8                                                 put x9-                PClass x1 x2 x3 x4 x5 x6 x7 x8 x9+                                                put x10+                                                put x11+                                                put x12+                PClass x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12                                          -> do putWord8 7                                                put x1                                                put x2@@ -1249,7 +1200,10 @@                                                put x7                                                put x8                                                put x9-                PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 ->+                                               put x10+                                               put x11+                                               put x12+                PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 ->                   do putWord8 8                      put x1                      put x2@@ -1261,6 +1215,7 @@                      put x8                      put x9                      put x10+                     put x11                 PDSL x1 x2 -> do putWord8 9                                  put x1                                  put x2@@ -1271,7 +1226,7 @@                 PMutual x1 x2  -> do putWord8 11                                      put x1                                      put x2-                PPostulate x1 x2 x3 x4 x5 x6+                PPostulate x1 x2 x3 x4 x5 x6 x7                                    -> do putWord8 12                                          put x1                                          put x2@@ -1279,6 +1234,7 @@                                          put x4                                          put x5                                          put x6+                                         put x7                 PSyntax x1 x2 -> do putWord8 13                                     put x1                                     put x2@@ -1309,7 +1265,8 @@                            x5 <- get                            x6 <- get                            x7 <- get-                           return (PTy x1 x2 x3 x4 x5 x6 x7)+                           x8 <- get+                           return (PTy x1 x2 x3 x4 x5 x6 x7 x8)                    2 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -1328,7 +1285,8 @@                            return (PParams x1 x2 x3)                    5 -> do x1 <- get                            x2 <- get-                           return (PNamespace x1 x2)+                           x3 <- get+                           return (PNamespace x1 x2 x3)                    6 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -1338,7 +1296,10 @@                            x7 <- get                            x8 <- get                            x9 <- get-                           return (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9)+                           x10 <- get+                           x11 <- get+                           x12 <- get+                           return (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)                    7 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -1348,7 +1309,10 @@                            x7 <- get                            x8 <- get                            x9 <- get-                           return (PClass x1 x2 x3 x4 x5 x6 x7 x8 x9)+                           x10 <- get+                           x11 <- get+                           x12 <- get+                           return (PClass x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)                    8 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -1359,7 +1323,8 @@                            x8 <- get                            x9 <- get                            x10 <- get-                           return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)+                           x11 <- get+                           return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)                    9 -> do x1 <- get                            x2 <- get                            return (PDSL x1 x2)@@ -1376,7 +1341,8 @@                             x4 <- get                             x5 <- get                             x6 <- get-                            return (PPostulate x1 x2 x3 x4 x5 x6)+                            x7 <- get+                            return (PPostulate x1 x2 x3 x4 x5 x6 x7)                    13 -> do x1 <- get                             x2 <- get                             return (PSyntax x1 x2)@@ -1501,23 +1467,27 @@ instance (Binary t) => Binary (PData' t) where         put x           = case x of-                PDatadecl x1 x2 x3 -> do putWord8 0-                                         put x1-                                         put x2-                                         put x3-                PLaterdecl x1 x2 -> do putWord8 1-                                       put x1-                                       put x2+                PDatadecl x1 x2 x3 x4 -> do putWord8 0+                                            put x1+                                            put x2+                                            put x3+                                            put x4+                PLaterdecl x1 x2 x3 -> do putWord8 1+                                          put x1+                                          put x2+                                          put x3         get           = do i <- getWord8                case i of                    0 -> do x1 <- get                            x2 <- get                            x3 <- get-                           return (PDatadecl x1 x2 x3)+                           x4 <- get+                           return (PDatadecl x1 x2 x3 x4)                    1 -> do x1 <- get                            x2 <- get-                           return (PLaterdecl x1 x2)+                           x3 <- get+                           return (PLaterdecl x1 x2 x3)                    _ -> error "Corrupted binary data for PData'"  instance Binary PunInfo where@@ -1548,22 +1518,25 @@                 PPatvar x1 x2 -> do putWord8 3                                     put x1                                     put x2-                PLam x1 x2 x3 x4 -> do putWord8 4-                                       put x1-                                       put x2-                                       put x3-                                       put x4-                PPi x1 x2 x3 x4 -> do putWord8 5-                                      put x1-                                      put x2-                                      put x3-                                      put x4-                PLet x1 x2 x3 x4 x5 -> do putWord8 6+                PLam x1 x2 x3 x4 x5 -> do putWord8 4                                           put x1                                           put x2                                           put x3                                           put x4                                           put x5+                PPi x1 x2 x3 x4 x5 -> do putWord8 5+                                         put x1+                                         put x2+                                         put x3+                                         put x4+                                         put x5+                PLet x1 x2 x3 x4 x5 x6 -> do putWord8 6+                                             put x1+                                             put x2+                                             put x3+                                             put x4+                                             put x5+                                             put x6                 PTyped x1 x2 -> do putWord8 7                                    put x1                                    put x2@@ -1586,17 +1559,8 @@                 PTrue x1 x2 -> do putWord8 12                                   put x1                                   put x2-                PRefl x1 x2 -> do putWord8 14-                                  put x1-                                  put x2                 PResolveTC x1 -> do putWord8 15                                     put x1-                PEq x1 x2 x3 x4 x5 -> do putWord8 16-                                         put x1-                                         put x2-                                         put x3-                                         put x4-                                         put x5                 PRewrite x1 x2 x3 x4 -> do putWord8 17                                            put x1                                            put x2@@ -1618,14 +1582,16 @@                                          put x2                 PHidden x1 -> do putWord8 21                                  put x1-                PType -> putWord8 22+                PType x1 -> do putWord8 22+                               put x1                 PGoal x1 x2 x3 x4 -> do putWord8 23                                         put x1                                         put x2                                         put x3                                         put x4-                PConstant x1 -> do putWord8 24-                                   put x1+                PConstant x1 x2 -> do putWord8 24+                                      put x1+                                      put x2                 Placeholder -> putWord8 25                 PDoBlock x1 -> do putWord8 26                                   put x1@@ -1634,8 +1600,9 @@                                    put x2                 PReturn x1 -> do putWord8 28                                  put x1-                PMetavar x1 -> do putWord8 29-                                  put x1+                PMetavar x1 x2 -> do putWord8 29+                                     put x1+                                     put x2                 PProof x1 -> do putWord8 30                                 put x1                 PTactics x1 -> do putWord8 31@@ -1652,9 +1619,9 @@                                     put x2                 PUniverse x1 -> do putWord8 38                                    put x1-                PRunTactics x1 x2 -> do putWord8 39-                                        put x1-                                        put x2+                PRunElab x1 x2 -> do putWord8 39+                                     put x1+                                     put x2                 PAs x1 x2 x3 -> do putWord8 40                                    put x1                                    put x2@@ -1666,7 +1633,13 @@                                         put x2                 PUnquote x1 -> do putWord8 43                                   put x1-+                PQuoteName x1 -> do putWord8 44+                                    put x1+                PIfThenElse x1 x2 x3 x4 -> do putWord8 45+                                              put x1+                                              put x2+                                              put x3+                                              put x4          get           = do i <- getWord8@@ -1686,18 +1659,21 @@                            x2 <- get                            x3 <- get                            x4 <- get-                           return (PLam x1 x2 x3 x4)+                           x5 <- get+                           return (PLam x1 x2 x3 x4 x5)                    5 -> do x1 <- get                            x2 <- get                            x3 <- get                            x4 <- get-                           return (PPi x1 x2 x3 x4)+                           x5 <- get+                           return (PPi x1 x2 x3 x4 x5)                    6 -> do x1 <- get                            x2 <- get                            x3 <- get                            x4 <- get                            x5 <- get-                           return (PLet x1 x2 x3 x4 x5)+                           x6 <- get+                           return (PLet x1 x2 x3 x4 x5 x6)                    7 -> do x1 <- get                            x2 <- get                            return (PTyped x1 x2)@@ -1719,17 +1695,8 @@                    12 -> do x1 <- get                             x2 <- get                             return (PTrue x1 x2)-                   14 -> do x1 <- get-                            x2 <- get-                            return (PRefl x1 x2)                    15 -> do x1 <- get                             return (PResolveTC x1)-                   16 -> do x1 <- get-                            x2 <- get-                            x3 <- get-                            x4 <- get-                            x5 <- get-                            return (PEq x1 x2 x3 x4 x5)                    17 -> do x1 <- get                             x2 <- get                             x3 <- get@@ -1751,14 +1718,16 @@                             return (PAlternative x1 x2)                    21 -> do x1 <- get                             return (PHidden x1)-                   22 -> return PType+                   22 -> do x1 <- get+                            return (PType x1)                    23 -> do x1 <- get                             x2 <- get                             x3 <- get                             x4 <- get                             return (PGoal x1 x2 x3 x4)                    24 -> do x1 <- get-                            return (PConstant x1)+                            x2 <- get+                            return (PConstant x1 x2)                    25 -> return Placeholder                    26 -> do x1 <- get                             return (PDoBlock x1)@@ -1768,7 +1737,8 @@                    28 -> do x1 <- get                             return (PReturn x1)                    29 -> do x1 <- get-                            return (PMetavar x1)+                            x2 <- get+                            return (PMetavar x1 x2)                    30 -> do x1 <- get                             return (PProof x1)                    31 -> do x1 <- get@@ -1787,7 +1757,7 @@                             return (PUniverse x1)                    39 -> do x1 <- get                             x2 <- get-                            return (PRunTactics x1 x2)+                            return (PRunElab x1 x2)                    40 -> do x1 <- get                             x2 <- get                             x3 <- get@@ -1799,8 +1769,30 @@                             return (PQuasiquote x1 x2)                    43 -> do x1 <- get                             return (PUnquote x1)+                   44 -> do x1 <- get+                            return (PQuoteName x1)+                   45 -> do x1 <- get+                            x2 <- get+                            x3 <- get+                            x4 <- get+                            return (PIfThenElse x1 x2 x3 x4)                    _ -> error "Corrupted binary data for PTerm" +instance Binary PAltType where+        put x +          = case x of+                ExactlyOne x1 -> do putWord8 0+                                    put x1+                FirstSuccess -> putWord8 1+        get+          = do i <- getWord8+               case i of+                   0 -> do x1 <- get+                           return (ExactlyOne x1)+                   1 -> return FirstSuccess+                   _ -> error "Corrupted binary data for PAltType"++ instance (Binary t) => Binary (PTactic' t) where         put x           = case x of@@ -1970,20 +1962,22 @@                 DoExp x1 x2 -> do putWord8 0                                   put x1                                   put x2-                DoBind x1 x2 x3 -> do putWord8 1-                                      put x1-                                      put x2-                                      put x3+                DoBind x1 x2 x3 x4 -> do putWord8 1+                                         put x1+                                         put x2+                                         put x3+                                         put x4                 DoBindP x1 x2 x3 x4 -> do putWord8 2                                           put x1                                           put x2                                           put x3                                           put x4-                DoLet x1 x2 x3 x4 -> do putWord8 3-                                        put x1-                                        put x2-                                        put x3-                                        put x4+                DoLet x1 x2 x3 x4 x5 -> do putWord8 3+                                           put x1+                                           put x2+                                           put x3+                                           put x4+                                           put x5                 DoLetP x1 x2 x3 -> do putWord8 4                                       put x1                                       put x2@@ -1997,7 +1991,8 @@                    1 -> do x1 <- get                            x2 <- get                            x3 <- get-                           return (DoBind x1 x2 x3)+                           x4 <- get+                           return (DoBind x1 x2 x3 x4)                    2 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -2007,7 +2002,8 @@                            x2 <- get                            x3 <- get                            x4 <- get-                           return (DoLet x1 x2 x3 x4)+                           x5 <- get+                           return (DoLet x1 x2 x3 x4 x5)                    4 -> do x1 <- get                            x2 <- get                            x3 <- get
src/Idris/IdeMode.hs view
@@ -7,11 +7,12 @@ import Text.Printf import Numeric import Data.List+import Data.Maybe (isJust) import qualified Data.Binary as Binary import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.UTF8 as UTF8--- import qualified Data.Text as T+import qualified Data.Text as T import Text.Trifecta hiding (Err) import Text.Trifecta.Delta import System.IO@@ -106,24 +107,25 @@ constTy :: Const -> String constTy (I _) = "Int" constTy (BI _) = "Integer"-constTy (Fl _) = "Float"+constTy (Fl _) = "Double" constTy (Ch _) = "Char" constTy (Str _) = "String" constTy (B8 _) = "Bits8" constTy (B16 _) = "Bits16" constTy (B32 _) = "Bits32" constTy (B64 _) = "Bits64"-constTy (B8V _) = "Bits8x16"-constTy (B16V _) = "Bits16x8"-constTy (B32V _) = "Bits32x4"-constTy (B64V _) = "Bits64x2" constTy _ = "Type" +namespaceOf :: Name -> Maybe String+namespaceOf (NS _ ns) = Just (intercalate "." $ reverse (map T.unpack ns))+namespaceOf _         = Nothing+ instance SExpable OutputAnnotation where   toSExp (AnnName n ty d t) = toSExp $ [(SymbolAtom "name", StringAtom (show n)),                                         (SymbolAtom "implicit", BoolAtom False)] ++                                        maybeProps [("decor", ty)] ++-                                       maybeProps [("doc-overview", d), ("type", t)]+                                       maybeProps [("doc-overview", d), ("type", t)] +++                                       maybeProps [("namespace", namespaceOf n)]   toSExp (AnnBoundName n imp)    = toSExp [(SymbolAtom "name", StringAtom (show n)),                                            (SymbolAtom "decor", SymbolAtom "bound"),                                            (SymbolAtom "implicit", BoolAtom imp)]@@ -154,6 +156,10 @@               LT -> "more general than searched type"               GT -> "more specific than searched type"   toSExp (AnnErr e) = toSExp [(SymbolAtom "error", StringAtom (encodeErr e))]+  toSExp (AnnNamespace ns file) =+    toSExp $ [(SymbolAtom "namespace", StringAtom (intercalate "." (map T.unpack ns)))] +++             [(SymbolAtom "decor", SymbolAtom $ if isJust file then "module" else "namespace")] +++             maybeProps [("source-file", file)]  encodeTerm :: [(Name, Bool)] -> Term -> String encodeTerm bnd tm = UTF8.toString . Base64.encode . Lazy.toStrict . Binary.encode $@@ -173,6 +179,8 @@     toSExp ((SymbolAtom "filename", StringAtom f),             (SymbolAtom "start",  IntegerAtom (toInteger sl), IntegerAtom (toInteger sc)),             (SymbolAtom "end", IntegerAtom (toInteger el), IntegerAtom (toInteger ec)))+  toSExp NoFC = toSExp ([] :: [String])+  toSExp (FileFC f) = toSExp [(SymbolAtom "filename", StringAtom f)]  escape :: String -> String escape = concatMap escapeChar@@ -226,6 +234,7 @@                     | Metavariables Int -- ^^ the Int is the column count for pretty-printing                     | WhoCalls String                     | CallsWho String+                    | BrowseNS String                     | TermNormalise [(Name, Bool)] Term                     | TermShowImplicits [(Name, Bool)] Term                     | TermNoImplicits [(Name, Bool)] Term@@ -273,6 +282,7 @@ sexpToCommand (SexpList [SymbolAtom "metavariables", IntegerAtom cols])                 = Just (Metavariables (fromIntegral cols)) sexpToCommand (SexpList [SymbolAtom "who-calls", StringAtom name])                      = Just (WhoCalls name) sexpToCommand (SexpList [SymbolAtom "calls-who", StringAtom name])                      = Just (CallsWho name)+sexpToCommand (SexpList [SymbolAtom "browse-namespace", StringAtom ns])                 = Just (BrowseNS ns) sexpToCommand (SexpList [SymbolAtom "normalise-term", StringAtom encoded])              = let (bnd, tm) = decodeTerm encoded in                                                                                           Just (TermNormalise bnd tm) sexpToCommand (SexpList [SymbolAtom "show-term-implicits", StringAtom encoded])         = let (bnd, tm) = decodeTerm encoded in
src/Idris/IdrisDoc.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}  -- | Generation of HTML documentation for Idris code module Idris.IdrisDoc (generateDocs) where@@ -165,11 +166,11 @@               -> [NsItem] -- ^ Orphan-free list removeOrphans list =   let children = S.fromList $ concatMap (names . (\(_, d, _) -> d)) list-  in  filter ((`S.notMember` children) . (\(n, _, _) -> n)) list+  in  filter ((flip S.notMember children) . (\(n, _, _) -> n)) list -  where names (Just (DataDoc _ fds))          = map (\(FD n _ _ _ _) -> n) fds-        names (Just (ClassDoc _ _ fds _ _ _ _)) = map (\(FD n _ _ _ _) -> n) fds-        names _                               = []+  where names (Just (DataDoc _ fds))              = map (\(FD n _ _ _ _) -> n) fds+        names (Just (ClassDoc _ _ fds _ _ _ _ c)) = map (\(FD n _ _ _ _) -> n) fds ++ map (\(FD n _ _ _ _) -> n) (maybeToList c)+        names _                                   = []  -- | Whether a Name names something which should be documented filterName :: Name -- ^ Name to check@@ -217,11 +218,13 @@       names  = concatMap (extractPTermNames) ts   in  S.map getNs $ S.fromList names -  where getFunDocs (FunDoc f)              = [f]-        getFunDocs (DataDoc f fs)          = f:fs-        getFunDocs (ClassDoc _ _ fs _ _ _ _) = fs-        types (FD _ _ args t _)            = t:(map second args)-        second (_, x, _, _)                = x+  where getFunDocs (FunDoc f)                  = [f]+        getFunDocs (DataDoc f fs)              = f:fs+        getFunDocs (ClassDoc _ _ fs _ _ _ _ _) = fs+        getFunDocs (NamedInstanceDoc _ fd)     = [fd]+        getFunDocs (ModDoc _ _)                = []+        types (FD _ _ args t _)                = t:(map second args)+        second (_, x, _, _)                    = x   -- | Returns an NsDict of containing all known namespaces and their contents@@ -288,9 +291,9 @@ extractPTermNames (PRef _ n)         = [n] extractPTermNames (PInferRef _ n)    = [n] extractPTermNames (PPatvar _ n)      = [n]-extractPTermNames (PLam _ n p1 p2)   = n : concatMap extract [p1, p2]-extractPTermNames (PPi _ n p1 p2)    = n : concatMap extract [p1, p2]-extractPTermNames (PLet _ n p1 p2 p3) = n : concatMap extract [p1, p2, p3]+extractPTermNames (PLam _ n _ p1 p2) = n : concatMap extract [p1, p2]+extractPTermNames (PPi _ n _ p1 p2)  = n : concatMap extract [p1, p2]+extractPTermNames (PLet _ n _ p1 p2 p3) = n : concatMap extract [p1, p2, p3] extractPTermNames (PTyped p1 p2)     = concatMap extract [p1, p2] extractPTermNames (PApp _ p pas)     = let names = concatMap extractPArg pas                                        in  (extract p) ++ names@@ -299,8 +302,7 @@ extractPTermNames (PMatchApp _ n)    = [n] extractPTermNames (PCase _ p ps)     = let (ps1, ps2) = unzip ps                                        in  concatMap extract (p:(ps1 ++ ps2))-extractPTermNames (PRefl _ p)        = extract p-extractPTermNames (PEq _ _ _ p1 p2)  = concatMap extract [p1, p2]+extractPTermNames (PIfThenElse _ c t f) = concatMap extract [c, t, f] extractPTermNames (PRewrite _ a b m) | Just c <- m =                                        concatMap extract [a, b, c] extractPTermNames (PRewrite _ a b _) = concatMap extract [a, b]@@ -311,14 +313,14 @@ extractPTermNames (PGoal _ p1 n p2)  = n : concatMap extract [p1, p2] extractPTermNames (PDoBlock pdos)    = concatMap extractPDo pdos extractPTermNames (PIdiom _ p)       = extract p-extractPTermNames (PMetavar n)       = [n]+extractPTermNames (PMetavar _ n)     = [n] extractPTermNames (PProof tacts)     = concatMap extractPTactic tacts extractPTermNames (PTactics tacts)   = concatMap extractPTactic tacts extractPTermNames (PCoerced p)       = extract p extractPTermNames (PDisamb _ p)      = extract p extractPTermNames (PUnifyLog p)      = extract p extractPTermNames (PNoImplicits p)   = extract p-extractPTermNames (PRunTactics _ p)  = extract p+extractPTermNames (PRunElab _ p)  = extract p extractPTermNames _                  = []  -- | Shorter name for extractPTermNames@@ -336,13 +338,13 @@  -- | Helper function for extractPTermNames extractPDo :: PDo -> [Name]-extractPDo (DoExp   _ p)        = extract p-extractPDo (DoBind  _ n p)      = n : extract p-extractPDo (DoBindP _ p1 p2 ps) = let (ps1, ps2) = unzip ps-                                      ps'        = ps1 ++ ps2-                                  in  concatMap extract (p1 : p2 : ps')-extractPDo (DoLet   _ n p1 p2)  = n : concatMap extract [p1, p2]-extractPDo (DoLetP  _ p1 p2)    = concatMap extract [p1, p2]+extractPDo (DoExp   _ p)         = extract p+extractPDo (DoBind  _ n _ p)     = n : extract p+extractPDo (DoBindP _ p1 p2 ps)  = let (ps1, ps2) = unzip ps+                                       ps'        = ps1 ++ ps2+                                   in  concatMap extract (p1 : p2 : ps')+extractPDo (DoLet   _ n _ p1 p2) = n : concatMap extract [p1, p2]+extractPDo (DoLetP  _ p1 p2)     = concatMap extract [p1, p2]  -- | Helper function for extractPTermNames extractPTactic :: PTactic -> [Name]@@ -417,7 +419,7 @@      BS2.hPut h $ renderHtml $ wrapper Nothing $ do        H.h1 $ "Namespaces"        H.ul ! class_ "names" $ do-         let path ns  = "docs" </> genRelNsPath ns "html"+         let path ns  = "docs" ++ "/" ++ genRelNsPath ns "html"              item ns  = do let n    = toHtml $ nsName2Str ns                                link = toValue $ path ns                            H.li $ H.a ! href link ! class_ "code" $ n@@ -575,7 +577,7 @@                -> H.Html -- ^ Resulting HTML createOtherDoc ist (FunDoc fd)                = createFunDoc ist fd -createOtherDoc ist (ClassDoc n docstring fds _ _ _ _) = do+createOtherDoc ist (ClassDoc n docstring fds _ _ _ _ c) = do   H.dt ! (A.id $ toValue $ show n) $ do     H.span ! class_ "word" $ do "class"; nbsp     H.span ! class_ "name type"@@ -584,7 +586,7 @@     H.span ! class_ "signature" $ nbsp   H.dd $ do     (if nullDocstring docstring then Empty else Docstrings.renderHtml docstring)-    H.dl ! class_ "decls" $ forM_ fds (createFunDoc ist)+    H.dl ! class_ "decls" $ (forM_ (maybeToList c ++ fds) (createFunDoc ist))    where name (NS n ns) = show (NS (sUN $ name n) ns)         name n         = let n' = show n@@ -609,6 +611,8 @@           H.dt $ toHtml $ show name           H.dd $ Docstrings.renderHtml docstring +createOtherDoc ist (NamedInstanceDoc _ fd) = createFunDoc ist fd+ createOtherDoc ist (ModDoc _  docstring) = do   Docstrings.renderHtml docstring @@ -658,7 +662,7 @@                                --   namespace pages                    -> IO (S.Set NsName) existingNamespaces out = do-  let docs     = out </> "docs"+  let docs     = out ++ "/" ++ "docs"       str2Ns s | s == rootNsStr = []       str2Ns s = reverse $ T.splitOn (T.singleton '.') (txt s)       toNs  fp = do isFile    <- doesFileExist $ docs </> fp
src/Idris/Inliner.hs view
@@ -21,7 +21,7 @@ inlineTerm :: IState -> Term -> Term inlineTerm ist tm = inl tm where   inl orig@(P _ n _) = inlApp n [] orig-  inl orig@(App f a)+  inl orig@(App _ f a)       | (P _ fn _, args) <- unApply orig = inlApp fn args orig   inl (Bind n (Let t v) sc) = Bind n (Let t (inl v)) (inl sc)   inl (Bind n b sc) = Bind n b (inl sc)
src/Idris/Interactive.hs view
@@ -12,13 +12,12 @@ import Idris.CaseSplit import Idris.AbsSyntax import Idris.ElabDecls-import Idris.ElabTerm import Idris.Error import Idris.Delaborate import Idris.Output import Idris.IdeMode hiding (IdeModeCommand(..))- import Idris.Elab.Value+import Idris.Elab.Term  import Util.Pretty import Util.System@@ -34,7 +33,7 @@  caseSplitAt :: FilePath -> Bool -> Int -> Name -> Idris () caseSplitAt fn updatefile l n-   = do src <- runIO $ readFile fn+   = do src <- runIO $ readSource fn         res <- splitOnLine l n fn         iLOG (showSep "\n" (map show res))         let (before, (ap : later)) = splitAt (l-1) (lines src)@@ -42,14 +41,14 @@         let new = concat res'         if updatefile           then do let fb = fn ++ "~" -- make a backup!-                  runIO $ writeFile fb (unlines before ++ new ++ unlines later)+                  runIO $ writeSource fb (unlines before ++ new ++ unlines later)                   runIO $ copyFile fb fn           else -- do iputStrLn (show res)             iPrintResult new  addClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris () addClauseFrom fn updatefile l n-   = do src <- runIO $ readFile fn+   = do src <- runIO $ readSource fn         let (before, tyline : later) = splitAt (l-1) (lines src)         let indent = getIndent 0 (show n) tyline         cl <- getClause l n fn@@ -57,7 +56,7 @@         let (nonblank, rest) = span (not . all isSpace) (tyline:later)         if updatefile           then do let fb = fn ++ "~"-                  runIO $ writeFile fb (unlines (before ++ nonblank) +++                  runIO $ writeSource fb (unlines (before ++ nonblank) ++                                         replicate indent ' ' ++                                         cl ++ "\n" ++                                         unlines rest)@@ -71,7 +70,7 @@  addProofClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris () addProofClauseFrom fn updatefile l n-   = do src <- runIO $ readFile fn+   = do src <- runIO $ readSource fn         let (before, tyline : later) = splitAt (l-1) (lines src)         let indent = getIndent 0 (show n) tyline         cl <- getProofClause l n fn@@ -79,7 +78,7 @@         let (nonblank, rest) = span (not . all isSpace) (tyline:later)         if updatefile           then do let fb = fn ++ "~"-                  runIO $ writeFile fb (unlines (before ++ nonblank) +++                  runIO $ writeSource fb (unlines (before ++ nonblank) ++                                         replicate indent ' ' ++                                         cl ++ "\n" ++                                         unlines rest)@@ -92,7 +91,7 @@  addMissing :: FilePath -> Bool -> Int -> Name -> Idris () addMissing fn updatefile l n-   = do src <- runIO $ readFile fn+   = do src <- runIO $ readSource fn         let (before, tyline : later) = splitAt (l-1) (lines src)         let indent = getIndent 0 (show n) tyline         i <- getIState@@ -106,7 +105,7 @@         let (nonblank, rest) = span (not . all isSpace) (tyline:later)         if updatefile           then do let fb = fn ++ "~"-                  runIO $ writeFile fb (unlines (before ++ nonblank)+                  runIO $ writeSource fb (unlines (before ++ nonblank)                                         ++ extras ++ unlines rest)                   runIO $ copyFile fb fn           else iPrintResult extras@@ -141,7 +140,7 @@  makeWith :: FilePath -> Bool -> Int -> Name -> Idris () makeWith fn updatefile l n-   = do src <- runIO $ readFile fn+   = do src <- runIO $ readSource fn         let (before, tyline : later) = splitAt (l-1) (lines src)         let ind = getIndent tyline         let with = mkWith tyline n@@ -151,7 +150,7 @@                                            not (ind == getIndent x)) later         if updatefile then            do let fb = fn ++ "~"-              runIO $ writeFile fb (unlines (before ++ nonblank)+              runIO $ writeSource fb (unlines (before ++ nonblank)                                         ++ with ++ "\n" ++                                     unlines rest)               runIO $ copyFile fb fn@@ -164,7 +163,7 @@ doProofSearch fn updatefile rec l n hints Nothing     = doProofSearch fn updatefile rec l n hints (Just 10) doProofSearch fn updatefile rec l n hints (Just depth)-    = do src <- runIO $ readFile fn+    = do src <- runIO $ readSource fn          let (before, tyline : later) = splitAt (l-1) (lines src)          ctxt <- getContext          mn <- case lookupNames n ctxt of@@ -192,15 +191,15 @@              (\e -> return ("?" ++ show n))          if updatefile then             do let fb = fn ++ "~"-               runIO $ writeFile fb (unlines before +++               runIO $ writeSource fb (unlines before ++                                      updateMeta False tyline (show n) newmv ++ "\n"                                        ++ unlines later)                runIO $ copyFile fb fn             else iPrintResult newmv     where dropCtxt 0 sc = sc-          dropCtxt i (PPi _ _ _ sc) = dropCtxt (i - 1) sc-          dropCtxt i (PLet _ _ _ _ sc) = dropCtxt (i - 1) sc-          dropCtxt i (PLam _ _ _ sc) = dropCtxt (i - 1) sc+          dropCtxt i (PPi _ _ _ _ sc) = dropCtxt (i - 1) sc+          dropCtxt i (PLet _ _ _ _ _ sc) = dropCtxt (i - 1) sc+          dropCtxt i (PLam _ _ _ _ sc) = dropCtxt (i - 1) sc           dropCtxt _ t = t            stripNS tm = mapPT dens tm where@@ -241,7 +240,7 @@  makeLemma :: FilePath -> Bool -> Int -> Name -> Idris () makeLemma fn updatefile l n-   = do src <- runIO $ readFile fn+   = do src <- runIO $ readSource fn         let (before, tyline : later) = splitAt (l-1) (lines src)          -- if the name is in braces, rather than preceded by a ?, treat it@@ -267,7 +266,7 @@              if updatefile then                do let fb = fn ++ "~"-                  runIO $ writeFile fb (addLem before tyline lem lem_app later)+                  runIO $ writeSource fb (addLem before tyline lem lem_app later)                   runIO $ copyFile fb fn                else case idris_outputmode i of                       RawOutput _  -> iPrintResult $ lem ++ "\n" ++ lem_app@@ -285,7 +284,7 @@                                  " = ?" ++ show n ++ "_rhs"             if updatefile then                do let fb = fn ++ "~"-                  runIO $ writeFile fb (addProv before tyline lem_app later)+                  runIO $ writeSource fb (addProv before tyline lem_app later)                   runIO $ copyFile fb fn                else case idris_outputmode i of                       RawOutput _  -> iPrintResult $ lem_app@@ -305,11 +304,11 @@         appArgs skip i (Bind _ (Pi _ _ _) sc) = appArgs skip (i - 1) sc         appArgs skip i _ = "" -        stripMNBind skip (PPi b n@(UN c) ty sc) +        stripMNBind skip (PPi b n@(UN c) _ ty sc)             | (thead c /= '_' && n `notElem` skip) ||                take 4 (str c) == "__pi" -- keep in type, but not in app-                = PPi b n ty (stripMNBind skip sc)-        stripMNBind skip (PPi b _ ty sc) = stripMNBind skip sc+                = PPi b n NoFC ty (stripMNBind skip sc)+        stripMNBind skip (PPi b _ _ ty sc) = stripMNBind skip sc         stripMNBind skip t = t          -- Guess which binders should be implicits in the generated lemma.@@ -323,7 +322,7 @@         guessImps ctxt _ = []          guarded ctxt n (P _ n' _) | n == n' = True-        guarded ctxt n ap@(App _ _)+        guarded ctxt n ap@(App _ _ _)             | (P _ f _, args) <- unApply ap,               isConName f ctxt = any (guarded ctxt n) args --         guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows
src/Idris/Output.hs view
@@ -15,10 +15,12 @@  import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) -import System.Console.Haskeline.MonadException +import System.Console.Haskeline.MonadException   (MonadException (controlIO), RunIO (RunIO)) import System.IO (stdout, Handle, hPutStrLn) +import Prelude hiding ((<$>))+ import Data.Char (isAlpha) import Data.List (nub, intersperse) import Data.Maybe (fromMaybe)@@ -31,20 +33,20 @@ pshow :: IState -> Err -> String pshow ist err = displayDecorated (consoleDecorate ist) .                 renderPretty 1.0 80 .-                fmap (fancifyAnnots ist) $ pprintErr ist err+                fmap (fancifyAnnots ist True) $ pprintErr ist err  iWarn :: FC -> Doc OutputAnnotation -> Idris () iWarn fc err =   do i <- getIState      case idris_outputmode i of        RawOutput h ->-         do err' <- iRender . fmap (fancifyAnnots i) $-                      if fc_fname fc /= ""-                        then text (show fc) <> colon <//> err-                        else err+         do err' <- iRender . fmap (fancifyAnnots i True) $+                      case fc of+                        FC fn _ _ | fn /= "" -> text (show fc) <> colon <//> err+                        _ -> err             runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'        IdeMode n h ->-         do err' <- iRender . fmap (fancifyAnnots i) $ err+         do err' <- iRender . fmap (fancifyAnnots i True) $ err             let (str, spans) = displaySpans err'             runIO . hPutStrLn h $               convSExp "warning" (fc_fname fc, fc_start fc, fc_end fc, str, spans) n@@ -95,7 +97,7 @@        RawOutput h -> do out <- iRender doc                          runIO $ putStrLn (displayDecorated (consoleDecorate i) out)        IdeMode n h ->-        do (str, spans) <- fmap displaySpans . iRender . fmap (fancifyAnnots i) $ doc+        do (str, spans) <- fmap displaySpans . iRender . fmap (fancifyAnnots i True) $ doc            let out = [toSExp str, toSExp spans]            runIO . hPutStrLn h $ convSExp "write-decorated" out n @@ -110,7 +112,7 @@   ist <- getIState   (str, spans) <- fmap displaySpans .                   iRender .-                  fmap (fancifyAnnots ist) $+                  fmap (fancifyAnnots ist True) $                   out   let good = [SymbolAtom status, toSExp str, toSExp spans]   runIO . hPutStrLn h $ convSExp "return" good n@@ -166,7 +168,7 @@                 case idris_outputmode i of                   RawOutput h -> runIO $ hPutStrLn h (displayDecorated (consoleDecorate i) g)                   IdeMode n h ->-                    let (str, spans) = displaySpans . fmap (fancifyAnnots i) $ g+                    let (str, spans) = displaySpans . fmap (fancifyAnnots i True) $ g                         goal = [toSExp str, toSExp spans]                     in runIO . hPutStrLn h $ convSExp "write-goal" goal n @@ -192,7 +194,26 @@   where ppTm = pprintDelab ist         norm = normaliseAll (tt_ctxt ist) [] +sendHighlighting :: [(FC, OutputAnnotation)] -> Idris ()+sendHighlighting highlights =+  do ist <- getIState+     case idris_outputmode ist of+       RawOutput _ -> return ()+       IdeMode n h ->+         let fancier = [ toSExp (fc, fancifyAnnots ist False annot)+                       | (fc, annot) <- highlights, fullFC fc+                       ]+         in case fancier of+              [] -> return ()+              _  -> runIO . hPutStrLn h $+                      convSExp "output"+                               (SymbolAtom "ok",+                                (SymbolAtom "highlight-source", fancier)) n +  where fullFC (FC _ _ _) = True+        fullFC _          = False++ renderExternal :: OutputFmt -> Int -> Doc OutputAnnotation -> Idris String renderExternal fmt width doc   | width < 1 = throwError . Msg $ "There must be at least one column for the pretty-printer."@@ -201,7 +222,7 @@        return . wrap fmt .          displayDecorated (decorate fmt) .          renderPretty 1.0 width .-         fmap (fancifyAnnots ist) $+         fmap (fancifyAnnots ist True) $            doc   where     decorate _ (AnnFC _) = id@@ -234,6 +255,7 @@     decorate HTMLOutput (AnnTerm _ _) = id     decorate HTMLOutput (AnnSearchResult _) = id     decorate HTMLOutput (AnnErr _) = id+    decorate HTMLOutput (AnnNamespace _ _) = id      decorate LaTeXOutput (AnnName _ (Just TypeOutput) _ _) =       latex "IdrisType"@@ -261,6 +283,7 @@     decorate LaTeXOutput (AnnTerm _ _) = id     decorate LaTeXOutput (AnnSearchResult _) = id     decorate LaTeXOutput (AnnErr _) = id+    decorate LaTeXOutput (AnnNamespace _ _) = id      tag cls docs str = "<span class=\""++cls++"\""++title++">" ++ str ++ "</span>"       where title = maybe "" (\d->" title=\"" ++ d ++ "\"") docs
src/Idris/ParseData.hs view
@@ -42,40 +42,104 @@     DocComment Accessibility? 'record' FnName TypeSig 'where' OpenBlock Constructor KeepTerminator CloseBlock; -} record :: SyntaxInfo -> IdrisParser PDecl-record syn = do (doc, argDocs, acc, opts) <- try (do-                      (doc, argDocs) <- option noDocs docComment+record syn = do (doc, paramDocs, acc, opts) <- try (do+                      (doc, paramDocs) <- option noDocs docComment                       ist <- get                       let doc' = annotCode (tryFullExpr syn ist) doc-                          argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)-                                     | (n, d) <- argDocs ]+                          paramDocs' = [ (n, annotCode (tryFullExpr syn ist) d)+                                     | (n, d) <- paramDocs ]                       acc <- optional accessibility                       opts <- dataOpts []-                      reserved "record"-                      return (doc', argDocs', acc, opts))+                      co <- recordI+                      return (doc', paramDocs', acc, opts ++ co))                 fc <- getFC-                tyn_in <- fnName-                lchar ':'-                ty <- typeExpr (allowImp syn)+                (tyn_in, nfc) <- fnName                 let tyn = expandNS syn tyn_in-                reserved "where"-                (cdoc, cargDocs, cn, cty, _, _) <- indentedBlockS (constructor syn)-                accData acc tyn [cn]                 let rsyn = syn { syn_namespace = show (nsroot tyn) :                                                     syn_namespace syn }-                let fns = getRecNames rsyn cty-                mapM_ (\n -> addAcc n acc) fns-                return $ PRecord doc rsyn fc tyn ty opts cdoc cn cty+                params <- manyTill (recordParameter rsyn) (reserved "where")+                (fields, cname, cdoc) <- indentedBlockS $ recordBody rsyn tyn+                case cname of+                     Just cn' -> accData acc tyn [fst cn']+                     Nothing -> return ()+                return $ PRecord doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc syn              <?> "record type declaration"   where     getRecNames :: SyntaxInfo -> PTerm -> [Name]-    getRecNames syn (PPi _ n _ sc) = [expandNS syn n, expandNS syn (mkType n)]-                                       ++ getRecNames syn sc+    getRecNames syn (PPi _ n _ _ sc) = [expandNS syn n, expandNS syn (mkType n)]+                                         ++ getRecNames syn sc     getRecNames _ _ = []      toFreeze :: Maybe Accessibility -> Maybe Accessibility     toFreeze (Just Frozen) = Just Hidden     toFreeze x = x +    recordBody :: SyntaxInfo -> Name -> IdrisParser ([((Maybe (Name, FC)), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))], Maybe (Name, FC), Docstring (Either Err PTerm))+    recordBody syn tyn = do+        ist <- get+        fc  <- getFC++        (constructorName, constructorDoc) <- option (Nothing, emptyDocstring)+                                             (do (doc, _) <- option noDocs docComment+                                                 n <- constructor+                                                 return (Just n, doc))++        let constructorDoc' = annotate syn ist constructorDoc++        fields <- many . indented $ field syn++        return (fields, constructorName, constructorDoc')+      where+        field :: SyntaxInfo -> IdrisParser ((Maybe (Name, FC)), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))+        field syn = do doc <- optional docComment+                       c <- optional $ lchar '{'+                       n <- (do (n, nfc) <- fnName+                                return $ Just (expandNS syn n, nfc))+                        <|> (do symbol "_"+                                return Nothing)+                       lchar ':'+                       t <- typeExpr (allowImp syn)+                       p <- endPlicity c+                       ist <- get+                       let doc' = case doc of -- Temp: Throws away any possible arg docs+                                   Just (d,_) -> Just $ annotate syn ist d+                                   Nothing    -> Nothing+                       return (n, p, t, doc')++        constructor :: IdrisParser (Name, FC)+        constructor = (reserved "constructor") *> fnName+++        endPlicity :: Maybe Char -> IdrisParser Plicity+        endPlicity (Just _) = do lchar '}'+                                 return impl+        endPlicity Nothing = return expl++        annotate :: SyntaxInfo -> IState -> Docstring () -> Docstring (Either Err PTerm)+        annotate syn ist = annotCode $ tryFullExpr syn ist++recordParameter :: SyntaxInfo -> IdrisParser (Name, FC, Plicity, PTerm)+recordParameter syn =+  (do lchar '('+      (n, nfc, pt) <- (namedTy syn <|> onlyName syn)+      lchar ')'+      return (n, nfc, expl, pt))+  <|>+  (do (n, nfc, pt) <- onlyName syn+      return (n, nfc, expl, pt))+  where+    namedTy :: SyntaxInfo -> IdrisParser (Name, FC, PTerm)+    namedTy syn =+      do (n, nfc) <- fnName+         lchar ':'+         ty <- typeExpr (allowImp syn)+         return (expandNS syn n, nfc, ty)+    onlyName :: SyntaxInfo -> IdrisParser (Name, FC, PTerm)+    onlyName syn =+      do (n, nfc) <- fnName+         fc <- getFC+         return (expandNS syn n, nfc, PType fc)+ {- | Parses data declaration type (normal or codata) DataI ::= 'data' | 'codata'; -}@@ -83,6 +147,10 @@ dataI = do reserved "data"; return []     <|> do reserved "codata"; return [Codata] +recordI :: IdrisParser DataOpts+recordI = do reserved "record"; return []+          <|> do reserved "corecord"; return [Codata]+ {- | Parses if a data should not have a default eliminator DefaultEliminator ::= 'noelim'?  -}@@ -123,20 +191,20 @@                                    | (n, d) <- argDocs ]                     return (doc', argDocs', acc, dataOpts))                fc <- getFC-               tyn_in <- fnName+               (tyn_in, nfc) <- fnName                (do try (lchar ':')                    popIndent                    ty <- typeExpr (allowImp syn)                    let tyn = expandNS syn tyn_in-                   option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn ty)) (do+                   option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn nfc ty)) (do                      reserved "where"                      cons <- indentedBlock (constructor syn)-                     accData acc tyn (map (\ (_, _, n, _, _, _) -> n) cons)-                     return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn ty cons))) <|> (do-                    args <- many name-                    let ty = bindArgs (map (const PType) args) PType+                     accData acc tyn (map (\ (_, _, n, _, _, _, _) -> n) cons)+                     return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn nfc ty cons))) <|> (do+                    args <- many (fst <$> name)+                    let ty = bindArgs (map (const (PType fc)) args) (PType fc)                     let tyn = expandNS syn tyn_in-                    option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn ty)) (do+                    option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn nfc ty)) (do                       try (lchar '=') <|> do reserved "where"                                              let kw = (if DefaultEliminator `elem` dataOpts then "%elim" else "") ++ (if Codata `elem` dataOpts then "co" else "") ++ "data "                                              let n  = show tyn_in ++ " "@@ -151,18 +219,18 @@                       cons <- sepBy1 (simpleConstructor syn) (reservedOp "|")                       terminator                       let conty = mkPApp fc (PRef fc tyn) (map (PRef fc) args)-                      cons' <- mapM (\ (doc, argDocs, x, cargs, cfc, fs) ->+                      cons' <- mapM (\ (doc, argDocs, x, xfc, cargs, cfc, fs) ->                                    do let cty = bindArgs cargs conty-                                      return (doc, argDocs, x, cty, cfc, fs)) cons-                      accData acc tyn (map (\ (_, _, n, _, _, _) -> n) cons')-                      return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn ty cons')))+                                      return (doc, argDocs, x, xfc, cty, cfc, fs)) cons+                      accData acc tyn (map (\ (_, _, n, _, _, _, _) -> n) cons')+                      return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn nfc ty cons')))            <?> "data type declaration"   where     mkPApp :: FC -> PTerm -> [PTerm] -> PTerm     mkPApp fc t [] = t     mkPApp fc t xs = PApp fc t (map pexp xs)     bindArgs :: [PTerm] -> PTerm -> PTerm-    bindArgs xs t = foldr (PPi expl (sMN 0 "_t")) t xs+    bindArgs xs t = foldr (PPi expl (sMN 0 "_t") NoFC) t xs     combineDataOpts :: DataOpts -> DataOpts     combineDataOpts opts = if Codata `elem` opts                               then delete DefaultEliminator opts@@ -172,36 +240,36 @@ {- | Parses a type constructor declaration   Constructor ::= DocComment? FnName TypeSig; -}-constructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, PTerm, FC, [Name])+constructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name]) constructor syn     = do (doc, argDocs) <- option noDocs docComment-         cn_in <- fnName; fc <- getFC+         (cn_in, nfc) <- fnName; fc <- getFC          let cn = expandNS syn cn_in          lchar ':'          fs <- option [] (do lchar '%'; reserved "erase"-                             sepBy1 name (lchar ','))+                             sepBy1 (fst <$> name) (lchar ','))          ty <- typeExpr (allowImp syn)          ist <- get          let doc' = annotCode (tryFullExpr syn ist) doc              argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)                         | (n, d) <- argDocs ]-         return (doc', argDocs', cn, ty, fc, fs)+         return (doc', argDocs', cn, nfc, ty, fc, fs)       <?> "constructor"  {- | Parses a constructor for simple discriminated union data types   SimpleConstructor ::= FnName SimpleExpr* DocComment? -}-simpleConstructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, [PTerm], FC, [Name])+simpleConstructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, [PTerm], FC, [Name]) simpleConstructor syn      = do (doc, _) <- option noDocs (try docComment)           ist <- get           let doc' = annotCode (tryFullExpr syn ist) doc-          cn_in <- fnName+          (cn_in, nfc) <- fnName           let cn = expandNS syn cn_in           fc <- getFC           args <- many (do notEndApp                            simpleExpr syn)-          return (doc', [], cn, args, fc, [])+          return (doc', [], cn, nfc, args, fc, [])        <?> "constructor"  {- | Parses a dsl block declaration@@ -209,7 +277,7 @@  -} dsl :: SyntaxInfo -> IdrisParser PDecl dsl syn = do reserved "dsl"-             n <- fnName+             n <- fst <$> fnName              bs <- indentedBlock (overload syn)              let dsl = mkDSL bs (dsl_info syn)              checkDSL dsl@@ -246,8 +314,8 @@ Overload ::= OverloadIdentifier '=' Expr; -} overload :: SyntaxInfo -> IdrisParser (String, PTerm)-overload syn = do o <- identifier <|> do reserved "let"-                                         return "let"+overload syn = do o <- (fst <$> identifier) <|> do reserved "let"+                                                   return "let"                   if o `notElem` overloadable                      then fail $ show o ++ " is not an overloading"                      else do
src/Idris/ParseExpr.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}-{-# OPTIONS_GHC -O0 #-} module Idris.ParseExpr where  import Prelude hiding (pi)@@ -143,7 +142,7 @@                                         return $ Just (n, SynTm tm)     extensionSymbol (SimpleExpr n) = do tm <- simpleExpr syn                                         return $ Just (n, SynTm tm)-    extensionSymbol (Binding n)    = do b <- name+    extensionSymbol (Binding n)    = do b <- fst <$> name                                         return $ Just (n, SynBind b)     extensionSymbol (Symbol s)     = do symbol s                                         return Nothing@@ -165,13 +164,13 @@     update ns (PRef fc n) = case lookup n ns of                               Just (SynTm t) -> t                               _ -> PRef fc n-    update ns (PLam fc n ty sc)-      = PLam fc (updateB ns n) (update ns ty) (update (dropn n ns) sc)-    update ns (PPi p n ty sc)-      = PPi (updTacImp ns p) (updateB ns n)+    update ns (PLam fc n nfc ty sc)+      = PLam fc (updateB ns n) nfc (update ns ty) (update (dropn n ns) sc)+    update ns (PPi p n fc ty sc)+      = PPi (updTacImp ns p) (updateB ns n) fc             (update ns ty) (update (dropn n ns) sc)-    update ns (PLet fc n ty val sc) -      = PLet fc (updateB ns n) (update ns ty)+    update ns (PLet fc n nfc ty val sc) +      = PLet fc (updateB ns n) nfc (update ns ty)               (update ns val) (update (dropn n ns) sc)     update ns (PApp fc t args)       = PApp fc (update ns t) (map (fmap (update ns)) args)@@ -179,6 +178,8 @@       = PAppBind fc (update ns t) (map (fmap (update ns)) args)     update ns (PCase fc c opts)       = PCase fc (update ns c) (map (pmap (update ns)) opts)+    update ns (PIfThenElse fc c t f)+      = PIfThenElse fc (update ns c) (update ns t) (update ns f)     update ns (PPair fc p l r) = PPair fc p (update ns l) (update ns r)     update ns (PDPair fc p l t r)       = PDPair fc p (update ns l) (update ns t) (update ns r)@@ -187,9 +188,9 @@     update ns (PDoBlock ds) = PDoBlock $ upd ns ds       where upd :: [(Name, SynMatch)] -> [PDo] -> [PDo]             upd ns (DoExp fc t : ds) = DoExp fc (update ns t) : upd ns ds-            upd ns (DoBind fc n t : ds) = DoBind fc n (update ns t) : upd (dropn n ns) ds-            upd ns (DoLet fc n ty t : ds) = DoLet fc n (update ns ty) (update ns t)-                                                : upd (dropn n ns) ds+            upd ns (DoBind fc n nfc t : ds) = DoBind fc n nfc (update ns t) : upd (dropn n ns) ds+            upd ns (DoLet fc n nfc ty t : ds) = DoLet fc n nfc (update ns ty) (update ns t)+                                                    : upd (dropn n ns) ds             upd ns (DoBindP fc i t ts : ds)                      = DoBindP fc (update ns i) (update ns t)                                   (map (\(l,r) -> (update ns l, update ns r)) ts)@@ -211,6 +212,7 @@   | Lambda   | QuoteGoal   | Let+  | If   | RewriteTerm   | CaseExpr   | DoBlock@@ -221,10 +223,11 @@ internalExpr :: SyntaxInfo -> IdrisParser PTerm internalExpr syn =          unifyLog syn-     <|> runTactics syn+     <|> runElab syn      <|> disamb syn      <|> noImplicits syn      <|> recordType syn+     <|> if_ syn      <|> lambda syn      <|> quoteGoal syn      <|> let_ syn@@ -234,6 +237,14 @@      <|> app syn      <?> "expression" +{- | Parses the "impossible" keyword+@+Impossible ::= 'impossible'+@+-}+impossible :: IdrisParser PTerm+impossible = PImpossible <$ reserved "impossible"+ {- | Parses a case expression @ CaseExpr ::=@@ -250,13 +261,13 @@ {- | Parses a case in a case expression @ CaseOption ::=-  Expr '=>' Expr Terminator+  Expr (Impossible | '=>' Expr) Terminator   ; @ -} caseOption :: SyntaxInfo -> IdrisParser (PTerm, PTerm) caseOption syn = do lhs <- expr (syn { inPattern = True })-                    symbol "=>"; r <- expr syn+                    r <- impossible <|> symbol "=>" *> expr syn                     return (lhs, r)                  <?> "case option" @@ -304,6 +315,7 @@   | Type   | 'Void'   | Quasiquote+  | NameQuote   | Unquote   | '_'   ;@@ -312,32 +324,30 @@ simpleExpr :: SyntaxInfo -> IdrisParser PTerm simpleExpr syn =             try (simpleExternalExpr syn)-        <|> do x <- try (lchar '?' *> name); return (PMetavar x)+        <|> do (x, FC f (l, c) end) <- try (lchar '?' *> name)+               return (PMetavar (FC f (l, c-1) end) x)         <|> do lchar '%'; fc <- getFC; reserved "instance"; return (PResolveTC fc)-        <|> do reserved "Refl"; fc <- getFC;-               tm <- option Placeholder (do lchar '{'; t <- expr syn; lchar '}';-                                            return t)-               return (PRefl fc tm)-        <|> do reserved "elim_for"; fc <- getFC; t <- fnName; return (PRef fc (SN $ ElimN t))+        <|> do reserved "elim_for"; fc <- getFC; t <- fst <$> fnName; return (PRef fc (SN $ ElimN t))         <|> proofExpr syn         <|> tacticsExpr syn         <|> try (do reserved "Type"; symbol "*"; return $ PUniverse AllTypes)-        <|> do reserved "Type"; return PType+        <|> do reserved "AnyType"; return $ PUniverse AllTypes+        <|> PType <$> reservedFC "Type"         <|> do reserved "UniqueType"; return $ PUniverse UniqueType         <|> do reserved "NullType"; return $ PUniverse NullType-        <|> do c <- constant+        <|> do (c, cfc) <- constant                fc <- getFC-               return (modifyConst syn fc (PConstant c))-        <|> do symbol "'"; fc <- getFC; str <- name+               return (modifyConst syn fc (PConstant cfc c))+        <|> do symbol "'"; fc <- getFC; str <- fst <$> name                return (PApp fc (PRef fc (sUN "Symbol_"))-                          [pexp (PConstant (Str (show str)))])-        <|> do fc <- getFC-               x <- fnName-               if inPattern syn +                          [pexp (PConstant NoFC (Str (show str)))])+        <|> do (x, fc) <- fnName+               if inPattern syn                   then option (PRef fc x)                               (do reservedOp "@"                                   s <- simpleExpr syn-                                  return (PAs fc x s))+                                  fcIn <- getFC+                                  return (PAs fcIn x s))                   else return (PRef fc x)         <|> idiom syn         <|> listExpr syn@@ -348,6 +358,7 @@                return (PAppBind fc s [])         <|> bracketed (disallowImp syn)         <|> quasiquote syn+        <|> namequote syn         <|> unquote syn         <|> do lchar '_'; return Placeholder         <?> "expression"@@ -358,8 +369,9 @@ @  -} bracketed :: SyntaxInfo -> IdrisParser PTerm-bracketed syn = do lchar '(' <?> "parenthesized expression"-                   bracketed' syn+bracketed syn = do fc <- getFC+                   lchar '(' <?> "parenthesized expression"+                   bracketed' fc syn {- |Parses the rest of an expression in braces @ Bracketed' ::=@@ -373,12 +385,12 @@   ; @ -}-bracketed' :: SyntaxInfo -> IdrisParser PTerm-bracketed' syn =-            do lchar ')'-               fc <- getFC-               return $ PTrue fc TypeOrTerm-        <|> try (do ln <- name; lchar ':';+bracketed' :: FC -> SyntaxInfo -> IdrisParser PTerm+bracketed' open syn =+            do (FC f start (l, c)) <- getFC+               lchar ')'+               return $ PTrue (spanFC open (FC f start (l, c+1))) TypeOrTerm+        <|> try (do ln <- fst <$> name; lchar ':';                     lty <- expr syn                     reservedOp "**"                     fc <- getFC@@ -389,7 +401,7 @@                     -- No prefix operators! (bit of a hack here...)                     if (o == "-" || o == "!")                       then fail "minus not allowed in section"-                      else return $ PLam fc (sMN 1000 "ARG") Placeholder+                      else return $ PLam fc (sMN 1000 "ARG") NoFC Placeholder                          (PApp fc (PRef fc (sUN o)) [pexp (PRef fc (sMN 1000 "ARG")),                                                      pexp e]))         <|> try (do l <- simpleExpr syn@@ -399,7 +411,7 @@                     fc0 <- getFC                     case op of                          Nothing -> bracketedExpr syn l-                         Just o -> return $ PLam fc0 (sMN 1000 "ARG") Placeholder+                         Just o -> return $ PLam fc0 (sMN 1000 "ARG") NoFC Placeholder                              (PApp fc0 (PRef fc0 (sUN o)) [pexp l,                                                            pexp (PRef fc0 (sMN 1000 "ARG"))]))         <|> do l <- expr syn@@ -431,19 +443,19 @@ -- name suggests, rather than Int {-| Finds optimal type for integer constant -} modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm-modifyConst syn fc (PConstant (BI x))+modifyConst syn fc (PConstant inFC (BI x))     | not (inPattern syn)-        = PAlternative False-             (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant (BI (fromInteger x)))]+        = PAlternative FirstSuccess+             (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant NoFC (BI (fromInteger x)))]              : consts)-    | otherwise = PAlternative False consts+    | otherwise = PAlternative FirstSuccess consts     where-      consts = [ PConstant (BI x)-               , PConstant (I (fromInteger x))-               , PConstant (B8 (fromInteger x))-               , PConstant (B16 (fromInteger x))-               , PConstant (B32 (fromInteger x))-               , PConstant (B64 (fromInteger x))+      consts = [ PConstant inFC (BI x)+               , PConstant inFC (I (fromInteger x))+               , PConstant inFC (B8 (fromInteger x))+               , PConstant inFC (B16 (fromInteger x))+               , PConstant inFC (B32 (fromInteger x))+               , PConstant inFC (B64 (fromInteger x))                ] modifyConst syn fc x = x @@ -459,7 +471,7 @@ -} alt :: SyntaxInfo -> IdrisParser PTerm alt syn = do symbol "(|"; alts <- sepBy1 (expr' syn) (lchar ','); symbol "|)"-             return (PAlternative False alts)+             return (PAlternative FirstSuccess alts)  {- | Parses a possibly hidden simple expression @@@ -490,16 +502,16 @@  {- | Parses a new-style tactics expression RunTactics ::=-  '%' 'runTactics' SimpleExpr+  '%' 'runElab' SimpleExpr   ; -}-runTactics :: SyntaxInfo -> IdrisParser PTerm-runTactics syn = do try (lchar '%' *> reserved "runTactics")-                    fc <- getFC-                    tm <- simpleExpr syn-                    i <- get-                    return $ PRunTactics fc tm-                 <?> "new-style tactics expression"+runElab :: SyntaxInfo -> IdrisParser PTerm+runElab syn = do try (lchar '%' *> reserved "runElab")+                 fc <- getFC+                 tm <- simpleExpr syn+                 i <- get+                 return $ PRunElab fc tm+              <?> "new-style tactics expression"  {- | Parses a disambiguation expression  Disamb ::=@@ -508,7 +520,7 @@ -} disamb :: SyntaxInfo -> IdrisParser PTerm disamb syn = do reserved "with";-                ns <- sepBy1 name (lchar ',')+                ns <- sepBy1 (fst <$> name) (lchar ',')                 tm <- expr' syn                 return (PDisamb (map tons ns) tm)                <?> "unification log expression"@@ -543,8 +555,8 @@ app syn = do f <- simpleExpr syn              (do try $ reservedOp "<=="                  fc <- getFC-                 ff <- fnName-                 return (PLet fc (sMN 0 "match")+                 ff <- fst <$> fnName+                 return (PLet fc (sMN 0 "match") NoFC                                f                                (PMatchApp fc ff)                                (PRef fc (sMN 0 "match")))@@ -582,7 +594,7 @@ -} implicitArg :: SyntaxInfo -> IdrisParser PArg implicitArg syn = do lchar '{'-                     n <- name+                     n <- fst <$> name                      fc <- getFC                      v <- option (PRef fc n) (do lchar '='                                                  expr syn)@@ -632,7 +644,19 @@                  return $ PUnquote e               <?> "unquotation" +{-| Parses a quotation of a name (for using the elaborator to resolve boring details) +> NameQuote ::= '`{' Name '}'++-}+namequote :: SyntaxInfo -> IdrisParser PTerm+namequote syn = do symbol "`{"+                   n <- fst <$> fnName+                   symbol "}"+                   return $ PQuoteName n+                <?> "quoted name"++ {-| Parses a record field setter expression @ RecordType ::=@@ -651,7 +675,7 @@ @ -} recordType :: SyntaxInfo -> IdrisParser PTerm-recordType syn = +recordType syn =       do reserved "record"          lchar '{'          fgs <- fieldGetOrSet@@ -662,13 +686,13 @@               Left fields ->                 case rec of                    Nothing ->-                       return (PLam fc (sMN 0 "fldx") Placeholder+                       return (PLam fc (sMN 0 "fldx") NoFC Placeholder                                    (applyAll fc fields (PRef fc (sMN 0 "fldx"))))                    Just v -> return (applyAll fc fields v)               Right fields ->                 case rec of                    Nothing ->-                       return (PLam fc (sMN 0 "fldx") Placeholder+                       return (PLam fc (sMN 0 "fldx") NoFC Placeholder                                  (getAll fc (reverse fields)                                       (PRef fc (sMN 0 "fldx"))))                    Just v -> return (getAll fc (reverse fields) v)@@ -682,7 +706,7 @@                     <?> "field setter"           fieldGet :: IdrisParser [Name]-         fieldGet = sepBy1 fnName (symbol "->")+         fieldGet = sepBy1 (fst <$> fnName) (symbol "->")           fieldGetOrSet :: IdrisParser (Either [([Name], PTerm)] [Name])          fieldGetOrSet = try (do fs <- sepBy1 fieldSet (lchar ',')@@ -732,8 +756,8 @@ {- | Parses a lambda expression @ Lambda ::=-    '\\' TypeOptDeclList '=>' Expr-  | '\\' SimpleExprList  '=>' Expr+    '\\' TypeOptDeclList LambdaTail+  | '\\' SimpleExprList  LambdaTail   ; @ @@@ -742,27 +766,34 @@   | SimpleExpr ',' SimpleExprList   ; @+@+LambdaTail ::=+    Impossible+  | '=>' Expr+@ -} lambda :: SyntaxInfo -> IdrisParser PTerm lambda syn = do lchar '\\' <?> "lambda expression"-                (do xt <- try $ tyOptDeclList syn-                    fc <- getFC-                    symbol "=>"-                    sc <- expr syn-                    return (bindList (PLam fc) xt sc)) <|> do-                      ps <- sepBy (do fc <- getFC-                                      e <- simpleExpr (syn { inPattern = True })-                                      return (fc, e)) (lchar ',')-                      symbol "=>"-                      sc <- expr syn-                      return (pmList (zip [0..] ps) sc)-                 <?> "lambda expression"+                ((do xt <- try $ tyOptDeclList syn+                     fc <- getFC+                     sc <- lambdaTail+                     return (bindList (PLam fc) xt sc))+                 <|>+                 (do ps <- sepBy (do fc <- getFC+                                     e <- simpleExpr (syn { inPattern = True })+                                     return (fc, e))+                                 (lchar ',')+                     sc <- lambdaTail+                     return (pmList (zip [0..] ps) sc)))+                  <?> "lambda expression"     where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm           pmList [] sc = sc           pmList ((i, (fc, x)) : xs) sc-                = PLam fc (sMN i "lamp") Placeholder+                = PLam fc (sMN i "lamp") NoFC Placeholder                         (PCase fc (PRef fc (sMN i "lamp"))                                 [(x, pmList xs sc)])+          lambdaTail :: IdrisParser PTerm+          lambdaTail = impossible <|> symbol "=>" *> expr syn  {- | Parses a term rewrite expression @@@ -800,12 +831,12 @@                    return (buildLets ls sc))            <?> "let binding"   where buildLets [] sc = sc-        buildLets ((fc,PRef _ n,ty,v,[]):ls) sc-          = PLet fc n ty v (buildLets ls sc)-        buildLets ((fc,pat,ty,v,alts):ls) sc+        buildLets ((fc, PRef nfc n, ty, v, []) : ls) sc+          = PLet fc n nfc ty v (buildLets ls sc)+        buildLets ((fc, pat, ty, v, alts) : ls) sc           = PCase fc v ((pat, buildLets ls sc) : alts) -let_binding syn = do fc <- getFC; +let_binding syn = do fc <- getFC;                      pat <- expr' (syn { inPattern = True })                      ty <- option Placeholder (do lchar ':'; expr' syn)                      lchar '='@@ -813,8 +844,25 @@                      ts <- option [] (do lchar '|'                                          sepBy1 (do_alt syn) (lchar '|'))                      return (fc,pat,ty,v,ts)-                   +{- | Parses a conditional expression+@+If ::= 'if' Expr 'then' Expr 'else' Expr+@++-}+if_ :: SyntaxInfo -> IdrisParser PTerm+if_ syn = (do reserved "if"+              fc <- getFC+              c <- expr syn+              reserved "then"+              t <- expr syn+              reserved "else"+              f <- expr syn+              return (PIfThenElse fc c t f))+          <?> "conditional expression"++ {- | Parses a quote goal  @@@ -824,7 +872,7 @@ @  -} quoteGoal :: SyntaxInfo -> IdrisParser PTerm-quoteGoal syn = do reserved "quoteGoal"; n <- name;+quoteGoal syn = do reserved "quoteGoal"; n <- fst <$> name;                    reserved "by"                    r <- expr syn                    reserved "in"@@ -854,49 +902,67 @@      = do symbol "->"           return (Exp opts st False) +explicitPi opts st syn+   = do xt <- try (lchar '(' *> typeDeclList syn <* lchar ')')+        binder <- bindsymbol opts st syn+        sc <- expr syn+        return (bindList (PPi binder) xt sc)+       +autoImplicit opts st syn+   = do reserved "auto"+        when (st == Static) $ fail "auto implicits can not be static"+        xt <- typeDeclList syn+        lchar '}'+        symbol "->"+        sc <- expr syn+        return (bindList (PPi+          (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing []]))) xt sc) ++defaultImplicit opts st syn = do+   reserved "default"+   when (st == Static) $ fail "default implicits can not be static"+   ist <- get+   script' <- simpleExpr syn+   let script = debindApp syn . desugar syn ist $ script'+   xt <- typeDeclList syn+   lchar '}'+   symbol "->"+   sc <- expr syn+   return (bindList (PPi (TacImp [] Dynamic script)) xt sc)++normalImplicit opts st syn = do+   xt <- typeDeclList syn <* lchar '}'+   symbol "->"+   cs <- constraintList syn+   sc <- expr syn+   let (im,cl)+          = if implicitAllowed syn+               then (Imp opts st False Nothing,+                      constraint)+               else (Imp opts st False (Just (Impl False)),+                     Imp opts st False (Just (Impl True)))+   return (bindList (PPi im) xt +           (bindList (PPi cl) cs sc))++implicitPi opts st syn =+      autoImplicit opts st syn+        <|> defaultImplicit opts st syn+          <|> normalImplicit opts st syn++unboundPi opts st syn = do+       x <- opExpr syn+       (do binder <- bindsymbol opts st syn+           sc <- expr syn+           return (PPi binder (sUN "__pi_arg") NoFC x sc))+              <|> return x+ pi :: SyntaxInfo -> IdrisParser PTerm pi syn =      do opts <- piOpts syn         st   <- static-        (do xt <- try (lchar '(' *> typeDeclList syn <* lchar ')')-            binder <- bindsymbol opts st syn-            sc <- expr syn-            return (bindList (PPi binder) xt sc)) <|> (do-               (do try (lchar '{' *> reserved "auto")-                   when (st == Static) $ fail "auto type constraints can not be static"-                   xt <- typeDeclList syn-                   lchar '}'-                   symbol "->"-                   sc <- expr syn-                   return (bindList (PPi-                     (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing []]))) xt sc)) <|> (do-                       try (lchar '{' *> reserved "default")-                       when (st == Static) $ fail "default tactic constraints can not be static"-                       ist <- get-                       script' <- simpleExpr syn-                       let script = debindApp syn . desugar syn ist $ script'-                       xt <- typeDeclList syn-                       lchar '}'-                       symbol "->"-                       sc <- expr syn-                       return (bindList (PPi (TacImp [] Dynamic script)) xt sc))-                 <|> (do xt <- try (lchar '{' *> typeDeclList syn <* lchar '}')-                         symbol "->"-                         cs <- constraintList syn-                         sc <- expr syn-                         let (im,cl)-                                = if implicitAllowed syn-                                     then (Imp opts st False Nothing,-                                            constraint)-                                     else (Imp opts st False (Just (Impl False)),-                                           Imp opts st False (Just (Impl True)))-                         return (bindList (PPi im) xt -                                 (bindList (PPi cl) cs sc))))-                 <|> (do x <- opExpr syn-                         (do binder <- bindsymbol opts st syn-                             sc <- expr syn-                             return (PPi binder (sUN "__pi_arg") x sc))-                          <|> return x)+        explicitPi opts st syn+         <|> try (do lchar '{'; implicitPi opts st syn)+            <|> unboundPi opts st syn   <?> "dependent type signature"  {- | Parses Possible Options for Pi Expressions@@ -919,25 +985,25 @@   ; @ -}-constraintList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]+constraintList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)] constraintList syn = try (constraintList1 syn)                      <|> return [] -constraintList1 :: SyntaxInfo -> IdrisParser [(Name, PTerm)]+constraintList1 :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)] constraintList1 syn = try (do lchar '('                               tys <- sepBy1 nexpr (lchar ',')                               lchar ')'                               reservedOp "=>"                               return tys)-                  <|> try (do t <- expr (disallowImp syn)+                  <|> try (do t <- opExpr (disallowImp syn)                               reservedOp "=>"-                              return [(defname, t)])+                              return [(defname, NoFC, t)])                   <?> "type constraint list"-  where nexpr = try (do n <- name; lchar ':'-                        e <- expr' (disallowImp syn)-                        return (n, e))-                <|> do e <- expr' (disallowImp syn)-                       return (defname, e)+  where nexpr = try (do (n, fc) <- name; lchar ':'+                        e <- expr syn+                        return (n, fc, e))+                <|> do e <- expr syn+                       return (defname, NoFC, e)         defname = sMN 0 "constrarg"  {- | Parses a type declaration list@@ -955,16 +1021,16 @@   ; @ -}-typeDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]-typeDeclList syn = try (sepBy1 (do x <- fnName+typeDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]+typeDeclList syn = try (sepBy1 (do (x, xfc) <- fnName                                    lchar ':'                                    t <- typeExpr (disallowImp syn)-                                   return (x,t))+                                   return (x, xfc, t))                            (lchar ','))                    <|> do ns <- sepBy1 name (lchar ',')                           lchar ':'                           t <- typeExpr (disallowImp syn)-                          return (map (\x -> (x, t)) ns)+                          return (map (\(x, xfc) -> (x, xfc, t)) ns)                    <?> "type declaration list"  {- | Parses a type declaration list with optional parameters@@ -979,17 +1045,17 @@ NameOrPlaceHolder ::= Name | '_'; @ -}-tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]-tyOptDeclList syn = sepBy1 (do x <- nameOrPlaceholder+tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]+tyOptDeclList syn = sepBy1 (do (x, fc) <- nameOrPlaceholder                                t <- option Placeholder (do lchar ':'                                                            expr syn)-                               return (x,t))+                               return (x, fc, t))                            (lchar ',')                     <?> "type declaration list"-    where  nameOrPlaceholder :: IdrisParser Name+    where  nameOrPlaceholder :: IdrisParser (Name, FC)            nameOrPlaceholder = fnName                            <|> do symbol "_"-                                  return (sMN 0 "underscore")+                                  return (sMN 0 "underscore", NoFC)                            <?> "name or placeholder"  {- | Parses a list literal expression e.g. [1,2,3] or a comprehension [ (x, y) | x <- xs , y <- ys ]@@ -1014,23 +1080,28 @@ @  -} listExpr :: SyntaxInfo -> IdrisParser PTerm-listExpr syn = do lchar '['; fc <- getFC;-                  try ((lchar ']' <?> "end of list expression") *> return (mkList fc [])) <|> (do-                    x <- expr syn <?> "expression"-                    (do try (lchar '|') <?> "list comprehension"-                        qs <- sepBy1 (do_ syn) (lchar ',')-                        lchar ']'-                        return (PDoBlock (map addGuard qs ++-                                   [DoExp fc (PApp fc (PRef fc (sUN "return"))-                                                [pexp x])]))) <|> (do-                          xs <- many ((lchar ',' <?> "list element") *> expr syn)-                          lchar ']' <?> "end of list expression"-                          return (mkList fc (x:xs))))+listExpr syn = do (FC f (l, c) _) <- getFC+                  lchar '['; fc <- getFC;+                  (try . token $ do (char ']' <?> "end of list expression")+                                    (FC _ _ (l', c')) <- getFC+                                    return (mkNil (FC f (l, c) (l', c'))))+                   <|> (do x <- expr syn <?> "expression"+                           (do try (lchar '|') <?> "list comprehension"+                               qs <- sepBy1 (do_ syn) (lchar ',')+                               lchar ']'+                               return (PDoBlock (map addGuard qs +++                                          [DoExp fc (PApp fc (PRef fc (sUN "return"))+                                                       [pexp x])]))) <|>+                            (do xs <- many ((lchar ',' <?> "list element") *> expr syn)+                                lchar ']' <?> "end of list expression"+                                return (mkList fc (x:xs))))                 <?> "list expression"   where+    mkNil :: FC -> PTerm+    mkNil fc = PRef fc (sUN "Nil")     mkList :: FC -> [PTerm] -> PTerm-    mkList fc [] = PRef fc (sUN "Nil")-    mkList fc (x : xs) = PApp fc (PRef fc (sUN "::")) [pexp x, pexp (mkList fc xs)]+    mkList fc [] = PRef NoFC (sUN "Nil")+    mkList fc (x : xs) = PApp fc (PRef NoFC (sUN "::")) [pexp x, pexp (mkList fc xs)]     addGuard :: PDo -> PDo     addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc (sUN "guard"))                                               [pexp e])@@ -1068,27 +1139,27 @@ do_ :: SyntaxInfo -> IdrisParser PDo do_ syn      = try (do reserved "let"-               i <- name+               (i, ifc) <- name                ty <- option Placeholder (do lchar ':'                                             expr' syn)                reservedOp "="                fc <- getFC                e <- expr syn-               return (DoLet fc i ty e))+               return (DoLet fc i ifc ty e))    <|> try (do reserved "let"                i <- expr' syn                reservedOp "="                fc <- getFC                sc <- expr syn                return (DoLetP fc i sc))-   <|> try (do i <- name+   <|> try (do (i, ifc) <- name                symbol "<-"                fc <- getFC                e <- expr syn;-               option (DoBind fc i e)+               option (DoBind fc i ifc e)                       (do lchar '|'                           ts <- sepBy1 (do_alt syn) (lchar '|')-                          return (DoBindP fc (PRef fc i) e ts)))+                          return (DoBindP fc (PRef ifc i) e ts)))    <|> try (do i <- expr' syn                symbol "<-"                fc <- getFC@@ -1129,19 +1200,12 @@     'Integer'   | 'Int'   | 'Char'-  | 'Float'+  | 'Double'   | 'String'-  | 'Ptr'-  | 'ManagedPtr'-  | 'prim__UnsafeBuffer'   | 'Bits8'   | 'Bits16'   | 'Bits32'   | 'Bits64'-  | 'Bits8x16'-  | 'Bits16x8'-  | 'Bits32x4'-  | 'Bits64x2'   | Float_t   | Natural_t   | VerbatimString_t@@ -1152,34 +1216,30 @@ -}  constants :: [(String, Idris.Core.TT.Const)]-constants = +constants =   [ ("Integer",            AType (ATInt ITBig))   , ("Int",                AType (ATInt ITNative))   , ("Char",               AType (ATInt ITChar))-  , ("Float",              AType ATFloat)+  , ("Double",             AType ATFloat)   , ("String",             StrType)-  , ("Ptr",                PtrType)-  , ("ManagedPtr",         ManagedPtrType)   , ("prim__WorldType",    WorldType)   , ("prim__TheWorld",     TheWorld)-  , ("prim__UnsafeBuffer", BufferType)   , ("Bits8",              AType (ATInt (ITFixed IT8)))   , ("Bits16",             AType (ATInt (ITFixed IT16)))   , ("Bits32",             AType (ATInt (ITFixed IT32)))   , ("Bits64",             AType (ATInt (ITFixed IT64)))-  , ("Bits8x16",           AType (ATInt (ITVec IT8 16)))-  , ("Bits16x8",           AType (ATInt (ITVec IT16 8)))-  , ("Bits32x4",           AType (ATInt (ITVec IT32 4)))-  , ("Bits64x2",           AType (ATInt (ITVec IT64 2)))   ]- -constant :: IdrisParser Idris.Core.TT.Const-constant = choice [ do reserved name; return ty | (name, ty) <- constants ]-        <|> do f <- try float;   return $ Fl f-        <|> do i <- natural; return $ BI i-        <|> do s <- verbatimStringLiteral; return $ Str s-        <|> do s <- stringLiteral;  return $ Str s-        <|> do c <- try charLiteral; return $ Ch c --Currently ambigous with symbols++-- | Parse a constant and its source span+constant :: IdrisParser (Idris.Core.TT.Const, FC)+constant = choice [ do fc <- reservedFC name; return (ty, fc)+                  | (name, ty) <- constants+                  ]+        <|> do (f, fc) <- try float; return (Fl f, fc)+        <|> do (i, fc) <- natural; return (BI i, fc)+        <|> do (s, fc) <- verbatimStringLiteral; return (Str s, fc)+        <|> do (s, fc) <- stringLiteral;  return (Str s, fc)+        <|> do (c, fc) <- try charLiteral; return (Ch c, fc) --Currently ambigous with symbols         <?> "constant or literal"  {- | Parses a verbatim multi-line string literal (triple-quoted)@@ -1190,9 +1250,12 @@ ; @  -}-verbatimStringLiteral :: MonadicParsing m => m String-verbatimStringLiteral = token $ do try $ string "\"\"\""-                                   manyTill anyChar $ try (string "\"\"\"")+verbatimStringLiteral :: MonadicParsing m => m (String, FC)+verbatimStringLiteral = token $ do (FC f start _) <- getFC+                                   try $ string "\"\"\""+                                   str <- manyTill anyChar $ try (string "\"\"\"")+                                   (FC _ _ end) <- getFC+                                   return (str, FC f start end)  {- | Parses a static modifier @@ -1259,26 +1322,26 @@ tactics :: [([String], Maybe TacticArg, SyntaxInfo -> IdrisParser PTactic)] tactics =    [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name)-      do ns <- sepBy (spaced name) (lchar ','); return $ Intro ns)+      do ns <- sepBy (spaced (fst <$> name)) (lchar ','); return $ Intro ns)   , noArgs ["intros"] Intros   , noArgs ["unfocus"] Unfocus   , (["refine"], Just ExprTArg, const $-       do n <- spaced fnName+       do n <- spaced (fst <$> fnName)           imps <- many imp           return $ Refine n imps)   , (["claim"], Nothing, \syn ->-       do n <- indentPropHolds gtProp *> name+       do n <- indentPropHolds gtProp *> (fst <$> name)           goal <- indentPropHolds gtProp *> expr syn           return $ Claim n goal)   , (["mrefine"], Just ExprTArg, const $-       do n <- spaced fnName+       do n <- spaced (fst <$> fnName)           return $ MatchRefine n)   , expressionTactic ["rewrite"] Rewrite   , expressionTactic ["case"] CaseTac   , expressionTactic ["induction"] Induction   , expressionTactic ["equiv"] Equiv   , (["let"], Nothing, \syn -> -- FIXME syntax for let-       do n <- (indentPropHolds gtProp *> name)+       do n <- (indentPropHolds gtProp *> (fst <$> name))           (do indentPropHolds gtProp *> lchar ':'               ty <- indentPropHolds gtProp *> expr' syn               indentPropHolds gtProp *> lchar '='@@ -1291,7 +1354,7 @@                     return $ LetTac n (desugar syn i t)))    , (["focus"], Just ExprTArg, const $-       do n <- spaced name+       do n <- spaced (fst <$> name)           return $ Focus n)   , expressionTactic ["exact"] Exact   , expressionTactic ["applyTactic"] ApplyTactic@@ -1307,7 +1370,7 @@   , noArgs ["trivial"] Trivial   , noArgs ["unify"] DoUnify   , (["search"], Nothing, const $-      do depth <- option 10 natural+      do depth <- option 10 $ fst <$> natural          return (ProofSearch True True (fromInteger depth) Nothing []))   , noArgs ["instance"] TCInstance   , noArgs ["solve"] Solve@@ -1323,11 +1386,11 @@   , expressionTactic [":t", ":type"] TCheck   , expressionTactic [":search"] TSearch   , (["fail"], Just StringLitTArg, const $-       do msg <- stringLiteral+       do msg <- fst <$> stringLiteral           return $ TFail [Idris.Core.TT.TextPart msg])   , ([":doc"], Just ExprTArg, const $        do whiteSpace-          doc <- (Right <$> constant) <|> (Left <$> fnName)+          doc <- (Right . fst <$> constant) <|> (Left . fst <$> fnName)           eof           return (TDocStr doc))   ]
src/Idris/ParseHelpers.hs view
@@ -67,6 +67,12 @@ -- | Generalized monadic parsing constraint type type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m) +class HasLastTokenSpan m where+  getLastTokenSpan :: m (Maybe FC)++instance HasLastTokenSpan IdrisParser where+  getLastTokenSpan = lastTokenSpan <$> get+ -- | Helper to run Idris inner parser based stateT parsers runparser :: StateT st IdrisInnerParser res -> st -> String -> String -> Result res runparser p i inputname =@@ -183,37 +189,43 @@                                many (satisfy isSpace)                                char '@'                                many (satisfy isSpace)-                               n <- name+                               n <- fst <$> name                                many (satisfy isSpace)                                docs <- many (satisfy (not . isEol))                                eol ; someSpace                                return (n, docs) -- -- | Parses some white space whiteSpace :: MonadicParsing m => m () whiteSpace = Tok.whiteSpace  -- | Parses a string literal-stringLiteral :: MonadicParsing m => m String-stringLiteral = Tok.stringLiteral+stringLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (String, FC)+stringLiteral = do str <- Tok.stringLiteral+                   fc <- getLastTokenSpan+                   return (str, fromMaybe NoFC fc) --- | Parses a char literal-charLiteral :: MonadicParsing m => m Char-charLiteral = Tok.charLiteral+-- | Parses a char literal+charLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (Char, FC)+charLiteral = do ch <- Tok.charLiteral+                 fc <- getLastTokenSpan+                 return (ch, fromMaybe NoFC fc)  -- | Parses a natural number-natural :: MonadicParsing m => m Integer-natural = Tok.natural+natural :: (MonadicParsing m, HasLastTokenSpan m) => m (Integer, FC)+natural = do n <- Tok.natural+             fc <- getLastTokenSpan+             return (n, fromMaybe NoFC fc)  -- | Parses an integral number integer :: MonadicParsing m => m Integer integer = Tok.integer  -- | Parses a floating point number-float :: MonadicParsing m => m Double-float = Tok.double+float :: (MonadicParsing m, HasLastTokenSpan m) => m (Double, FC)+float = do f <- Tok.double+           fc <- getLastTokenSpan+           return (f, fromMaybe NoFC fc)  {- * Symbols, identifiers, names and operators -} @@ -224,14 +236,15 @@   where _styleName = "Idris"         _styleStart = satisfy isAlpha <|> oneOf "_"         _styleLetter = satisfy isAlphaNum <|> oneOf "_'."-        _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "Type",+        _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "corecord", "Type",                                       "do", "dsl", "import", "impossible",                                       "case", "of", "total", "partial", "mutual",                                       "infix", "infixl", "infixr", "rewrite",                                       "where", "with", "syntax", "proof", "postulate",                                       "using", "namespace", "class", "instance", "parameters",                                       "public", "private", "abstract", "implicit",-                                      "quoteGoal"]+                                      "quoteGoal", "constructor",+                                      "if", "then", "else"]  char :: MonadicParsing m => Char -> m Char char = Chr.char@@ -251,6 +264,13 @@ reserved :: MonadicParsing m => String -> m () reserved = Tok.reserve idrisStyle +-- | Parses a reserved identifier, computing its span. Assumes that+-- reserved identifiers never contain line breaks.+reservedFC :: MonadicParsing m => String -> m FC+reservedFC str = do (FC file (l, c) _) <- getFC+                    Tok.reserve idrisStyle str+                    return $ FC file (l, c) (l, c + length str)+ -- Taken from Parsec (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 -- | Parses a reserved operator reservedOp :: MonadicParsing m => String -> m ()@@ -258,37 +278,55 @@   do string name      notFollowedBy (operatorLetter) <?> ("end of " ++ show name) --- | Parses an identifier as a token-identifier :: MonadicParsing m => m String-identifier = try(do i <- token $ Tok.ident idrisStyle+reservedOpFC :: MonadicParsing m => String -> m FC+reservedOpFC name = token $ try $ do (FC f (l, c) _) <- getFC+                                     string name+                                     notFollowedBy (operatorLetter) <?> ("end of " ++ show name)+                                     return (FC f (l, c) (l, c + length name))++-- | Parses an identifier as a token+identifier :: (MonadicParsing m) => m (String, FC)+identifier = try(do (i, fc) <-+                      token $ do (FC f (l, c) _) <- getFC+                                 i <- Tok.ident idrisStyle+                                 return (i, FC f (l, c) (l, c + length i))                     when (i == "_") $ unexpected "wildcard"-                    return i)+                    return (i, fc))  -- | Parses an identifier with possible namespace as a name-iName :: MonadicParsing m => [String] -> m Name-iName bad = maybeWithNS identifier False bad <?> "name"+iName :: (MonadicParsing m, HasLastTokenSpan m) => [String] -> m (Name, FC)+iName bad = do (n, fc) <- maybeWithNS identifier False bad+               return (n, fc)+            <?> "name"  -- | Parses an string possibly prefixed by a namespace-maybeWithNS :: MonadicParsing m => m String -> Bool -> [String] -> m Name+maybeWithNS :: (MonadicParsing m, HasLastTokenSpan m) => m (String, FC) -> Bool -> [String] -> m (Name, FC) maybeWithNS parser ascend bad = do-  i <- option "" (lookAhead identifier)+  fc <- getFC+  i <- option "" (lookAhead (fst <$> identifier))   when (i `elem` bad) $ unexpected "reserved identifier"   let transf = if ascend then id else reverse-  (x, xs) <- choice (transf (parserNoNS parser : parsersNS parser i))-  return $ mkName (x, xs)-  where parserNoNS :: MonadicParsing m => m String -> m (String, String)-        parserNoNS parser = do x <- parser; return (x, "")-        parserNS   :: MonadicParsing m => m String -> String -> m (String, String)-        parserNS   parser ns = do xs <- string ns; lchar '.';  x <- parser; return (x, xs)-        parsersNS  :: MonadicParsing m => m String -> String -> [m (String, String)]-        parsersNS parser i = [try (parserNS parser ns) | ns <- (initsEndAt (=='.') i)]+  (x, xs, fc) <- choice (transf (parserNoNS parser : parsersNS parser i))+  return (mkName (x, xs), fc)+  where parserNoNS :: MonadicParsing m => m (String, FC) -> m (String, String, FC)+        parserNoNS parser = do startFC <- getFC+                               (x, nameFC) <- parser+                               return (x, "", spanFC startFC nameFC)+        parserNS   :: MonadicParsing m => m (String, FC) -> String -> m (String, String, FC)+        parserNS   parser ns = do startFC <- getFC+                                  xs <- string ns+                                  lchar '.';  (x, nameFC) <- parser+                                  return (x, xs, spanFC startFC nameFC)+        parsersNS  :: MonadicParsing m => m (String, FC) -> String -> [m (String, String, FC)]+        parsersNS parser i = [try (parserNS parser ns) | ns <- (initsEndAt (=='.') i)]  -- | Parses a name-name :: IdrisParser Name+name :: IdrisParser (Name, FC) name = (<?> "name") $ do     keywords <- syntax_keywords <$> get     aliases  <- module_aliases  <$> get-    unalias aliases <$> iName keywords+    (n, fc) <- iName keywords+    return (unalias aliases n, fc)   where     unalias :: M.Map [T.Text] [T.Text] -> Name -> Name     unalias aliases (NS n ns) | Just ns' <- M.lookup ns aliases = NS n ns'@@ -335,6 +373,15 @@                    fail $ op ++ " is not a valid operator"               return op +-- | Parses an operator+operatorFC :: MonadicParsing m => m (String, FC)+operatorFC = do (op, fc) <- token $ do (FC f (l, c) _) <- getFC+                                       op <- some operatorLetter+                                       return (op, FC f (l, c) (l, c + length op))+                when (op `elem` (invalidOperators ++ commentMarkers)) $+                     fail $ op ++ " is not a valid operator"+                return (op, fc)+ {- * Position helpers -} {- | Get filename from position (returns "(interactive)" when no source file is given)  -} fileName :: Delta -> String@@ -361,11 +408,12 @@            -- Issue #1594 on the Issue Tracker.            -- https://github.com/idris-lang/Idris-dev/issues/1594 + {-* Syntax helpers-} -- | Bind constraints to term-bindList :: (Name -> PTerm -> PTerm -> PTerm) -> [(Name, PTerm)] -> PTerm -> PTerm-bindList b []          sc = sc-bindList b ((n, t):bs) sc = b n t (bindList b bs sc)+bindList :: (Name -> FC -> PTerm -> PTerm -> PTerm) -> [(Name, FC, PTerm)] -> PTerm -> PTerm+bindList b []              sc = sc+bindList b ((n, fc, t):bs) sc = b n fc t (bindList b bs sc)  {- * Layout helpers -} @@ -584,10 +632,10 @@         fcOf (PClauses fc _ _ _) = fc collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds-collect (PNamespace ns ps : ds) = PNamespace ns (collect ps) : collect ds-collect (PClass doc f s cs n ps pdocs fds ds : ds')-    = PClass doc f s cs n ps pdocs fds (collect ds) : collect ds'-collect (PInstance doc argDocs f s cs n ps t en ds : ds')-    = PInstance doc argDocs f s cs n ps t en (collect ds) : collect ds'+collect (PNamespace ns fc ps : ds) = PNamespace ns fc (collect ps) : collect ds+collect (PClass doc f s cs n nfc ps pdocs fds ds cn cd : ds')+    = PClass doc f s cs n nfc ps pdocs fds (collect ds) cn cd : collect ds'+collect (PInstance doc argDocs f s cs n nfc ps t en ds : ds')+    = PInstance doc argDocs f s cs n nfc ps t en (collect ds) : collect ds' collect (d : ds) = d : collect ds collect [] = []
src/Idris/ParseOps.hs view
@@ -29,6 +29,8 @@ import qualified Data.Text as T import qualified Data.ByteString.UTF8 as UTF8 +import Debug.Trace+ -- | Creates table for fixity declarations to build expression parser -- using pre-build and user-defined operator/fixity declarations table :: [FixDecl] -> OperatorTable IdrisParser PTerm@@ -37,7 +39,7 @@      toTable (reverse fixes) ++      [[backtick],       [binary "$" (\fc x y -> flatten $ PApp fc x [pexp y]) AssocRight],-      [binary "="  (\fc x y -> PEq fc Placeholder Placeholder x y) AssocLeft],+      [binary "="  (\fc x y -> PApp fc (PRef fc eqTy) [pexp x, pexp y]) AssocLeft],       [nofixityoperator]]   where     flatten :: PTerm -> PTerm -- flatten application@@ -45,7 +47,7 @@     flatten t = t  --- | Calculates table for fixtiy declarations+-- | Calculates table for fixity declarations toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm toTable fs = map (map toBin)                  (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)@@ -59,9 +61,8 @@  -- | Binary operator binary :: String -> (FC -> PTerm -> PTerm -> PTerm) -> Assoc -> Operator IdrisParser PTerm-binary name f = Infix (do fc <- getFC-                          indentPropHolds gtProp-                          reservedOp name+binary name f = Infix (do indentPropHolds gtProp+                          fc <- reservedOpFC name                           indentPropHolds gtProp                           return (f fc)) @@ -75,10 +76,9 @@ -- | Backtick operator backtick :: Operator IdrisParser PTerm backtick = Infix (do indentPropHolds gtProp-                     lchar '`'; n <- fnName+                     lchar '`'; (n, fc) <- fnName                      lchar '`'                      indentPropHolds gtProp-                     fc <- getFC                      return (\x y -> PApp fc (PRef fc n) [pexp x, pexp y])) AssocNone  -- | Operator without fixity (throws an error)@@ -86,8 +86,8 @@ nofixityoperator = Infix (do indentPropHolds gtProp                              op <- try operator                              unexpected $ "Operator without known fixity: " ++ op) AssocNone-                              + {- | Parses an operator in function position i.e. enclosed by `()', with an  optional namespace @@ -99,9 +99,15 @@ @  -}-operatorFront :: IdrisParser Name-operatorFront = try ((lchar '(' *> reservedOp "="  <* lchar ')') >> (return eqTy))-            <|> maybeWithNS (lchar '(' *> operator <* lchar ')') False []+operatorFront :: IdrisParser (Name, FC)+operatorFront = try (do (FC f (l, c) _) <- getFC+                        op <- lchar '(' *> reservedOp "="  <* lchar ')'+                        return (eqTy, FC f (l, c) (l, c+3)))+            <|> maybeWithNS (do (FC f (l, c) _) <- getFC+                                op <- lchar '(' *> operator+                                (FC _ _ (l', c')) <- getFC+                                lchar ')'+                                return (op, (FC f (l, c) (l', c' + 1)))) False []  {- | Parses a function (either normal name or operator) @@ -109,7 +115,7 @@   FnName ::= Name | OperatorFront; @ -}-fnName :: IdrisParser Name+fnName :: IdrisParser (Name, FC) fnName = try operatorFront <|> name <?> "function name"  {- | Parses a fixity declaration@@ -121,7 +127,8 @@ -} fixity :: IdrisParser PDecl fixity = do pushIndent-            f <- fixityType; i <- natural; ops <- sepBy1 operator (lchar ',')+            f <- fixityType; i <- fst <$> natural;+            ops <- sepBy1 operator (lchar ',')             terminator             let prec = fromInteger i             istate <- get
src/Idris/Parser.hs view
@@ -8,6 +8,8 @@  import Prelude hiding (pi) +import qualified System.Directory as Dir (makeAbsolute)+ import Text.Trifecta.Delta import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace, Err) import Text.Parser.LookAhead@@ -25,8 +27,8 @@ import Idris.Delaborate import Idris.Error import Idris.Elab.Value+import Idris.Elab.Term import Idris.ElabDecls-import Idris.ElabTerm import Idris.Coverage import Idris.IBC import Idris.Unlit@@ -43,6 +45,7 @@ import Paths_idris  import Util.DynamicLinker+import Util.System (readSource, writeSource) import qualified Util.Pretty as P  import Idris.Core.TT@@ -91,38 +94,52 @@       ModuleHeader ::= DocComment_t? 'module' Identifier_t ';'?; @ -}-moduleHeader :: IdrisParser (Maybe (Docstring ()), [String])+moduleHeader :: IdrisParser (Maybe (Docstring ()), [String], [(FC, OutputAnnotation)]) moduleHeader =     try (do docs <- optional docComment                            noArgs docs                            reserved "module"-                           i <- identifier+                           (i, ifc) <- identifier                            option ';' (lchar ';')-                           return (fmap fst docs, moduleName i))+                           let modName = moduleName i+                           return (fmap fst docs,+                                   modName,+                                   [(ifc, AnnNamespace (map T.pack modName) Nothing)]))                <|> try (do lchar '%'; reserved "unqualified"-                           return (Nothing, []))-               <|> return (Nothing, moduleName "Main")+                           return (Nothing, [], []))+               <|> return (Nothing, moduleName "Main", [])   where moduleName x = case span (/='.') x of                            (x, "")    -> [x]                            (x, '.':y) -> x : moduleName y         noArgs (Just (_, args)) | not (null args) = fail "Modules do not take arguments"         noArgs _ = return () +data ImportInfo = ImportInfo { import_reexport :: Bool+                             , import_path :: FilePath+                             , import_rename :: Maybe (String, FC)+                             , import_namespace :: [T.Text]+                             , import_location :: FC+                             , import_modname_location :: FC+                             }+ {- | Parses an import statement  @   Import ::= 'import' Identifier_t ';'?; @  -}-import_ :: IdrisParser (Bool, String, Maybe String, FC)+import_ :: IdrisParser ImportInfo import_ = do fc <- getFC              reserved "import"              reexport <- option False (do reserved "public"; return True)-             id <- identifier+             (id, idfc) <- identifier              newName <- optional (reserved "as" *> identifier)              option ';' (lchar ';')-             return (reexport, toPath id, toPath <$> newName, fc)+             return $ ImportInfo reexport (toPath id)+                        (fmap (\(n, fc) -> (toPath n, fc)) newName)+                        (map T.pack $ ns id) fc idfc           <?> "import statement"-  where toPath = foldl1' (</>) . Spl.splitOn "."+  where ns = Spl.splitOn "."+        toPath = foldl1' (</>) . ns  {- | Parses program source @@ -309,22 +326,22 @@           return $ PRef fc n'         fixBind rens (PPatvar fc n) | Just n' <- lookup n rens =           return $ PPatvar fc n'-        fixBind rens (PLam fc n ty body)-          | n `elem` userNames = liftM2 (PLam fc n) (fixBind rens ty) (fixBind rens body)+        fixBind rens (PLam fc n nfc ty body)+          | n `elem` userNames = liftM2 (PLam fc n nfc) (fixBind rens ty) (fixBind rens body)           | otherwise =             do ty' <- fixBind rens ty                n' <- gensym n                body' <- fixBind ((n,n'):rens) body-               return $ PLam fc n' ty' body'-        fixBind rens (PPi plic n argTy body)-          | n `elem` userNames = liftM2 (PPi plic n) (fixBind rens argTy) (fixBind rens body)+               return $ PLam fc n' nfc ty' body'+        fixBind rens (PPi plic n nfc argTy body)+          | n `elem` userNames = liftM2 (PPi plic n nfc) (fixBind rens argTy) (fixBind rens body)           | otherwise =             do ty' <- fixBind rens argTy                n' <- gensym n                body' <- fixBind ((n,n'):rens) body-               return $ (PPi plic n' ty' body')-        fixBind rens (PLet fc n ty val body)-          | n `elem` userNames = liftM3 (PLet fc n)+               return $ (PPi plic n' nfc ty' body')+        fixBind rens (PLet fc n nfc ty val body)+          | n `elem` userNames = liftM3 (PLet fc n nfc)                                         (fixBind rens ty)                                         (fixBind rens val)                                         (fixBind rens body)@@ -333,7 +350,7 @@                val' <- fixBind rens val                n' <- gensym n                body' <- fixBind ((n,n'):rens) body-               return $ (PLet fc n' ty' val' body')+               return $ PLet fc n' nfc ty' val' body'         fixBind rens (PMatchApp fc n) | Just n' <- lookup n rens =           return $ PMatchApp fc n'         fixBind rens x = descendM (fixBind rens) x@@ -355,13 +372,13 @@ @  -} syntaxSym :: IdrisParser SSymbol-syntaxSym =    try (do lchar '['; n <- name; lchar ']'+syntaxSym =    try (do lchar '['; n <- fst <$> name; lchar ']'                        return (Expr n))-            <|> try (do lchar '{'; n <- name; lchar '}'+            <|> try (do lchar '{'; n <- fst <$> name; lchar '}'                         return (Binding n))-            <|> do n <- iName []+            <|> do n <- fst <$> iName []                    return (Keyword n)-            <|> do sym <- stringLiteral+            <|> do sym <- fmap fst stringLiteral                    return (Symbol sym)             <?> "syntax symbol" @@ -391,7 +408,7 @@ -} fnDecl' :: SyntaxInfo -> IdrisParser PDecl fnDecl' syn = checkFixity $-              do (doc, argDocs, fc, opts', n, acc) <- try (do+              do (doc, argDocs, fc, opts', n, nfc, acc) <- try (do                         pushIndent                         (doc, argDocs) <- docstring syn                         ist <- get@@ -401,15 +418,15 @@                         opts <- fnOpts initOpts                         acc <- optional accessibility                         opts' <- fnOpts opts-                        n_in <- fnName+                        (n_in, nfc) <- fnName                         let n = expandNS syn n_in                         fc <- getFC                         lchar ':'-                        return (doc, argDocs, fc, opts', n, acc))+                        return (doc, argDocs, fc, opts', n, nfc, acc))                  ty <- typeExpr (allowImp syn)                  terminator                  addAcc n acc-                 return (PTy doc argDocs syn fc opts' n ty)+                 return (PTy doc argDocs syn fc opts' n nfc ty)             <|> postulate syn             <|> caf syn             <|> pattern syn@@ -422,7 +439,7 @@                                             unless fOk . fail $                                               "Missing fixity declaration for " ++ show n                                             return decl-          getName (PTy _ _ _ _ _ n _) = Just n+          getName (PTy _ _ _ _ _ n _ _) = Just n           getName _ = Nothing           fixityOK (NS n _) = fixityOK n           fixityOK (UN n)  | all (flip elem opChars) (str n) =@@ -436,6 +453,7 @@ @ FnOpts ::= 'total'   | 'partial'+  | 'covering'   | 'implicit'   | '%' 'no_implicit'   | '%' 'assert_total'@@ -465,7 +483,7 @@         = do reserved "total"; fnOpts (TotalFn : opts)       <|> do reserved "partial"; fnOpts (PartialFn : (opts \\ [TotalFn]))       <|> do reserved "covering"; fnOpts (CoveringFn : (opts \\ [TotalFn]))-      <|> do try (lchar '%' *> reserved "export"); c <- stringLiteral;+      <|> do try (lchar '%' *> reserved "export"); c <- fmap fst stringLiteral;                   fnOpts (CExport c : opts)       <|> do try (lchar '%' *> reserved "no_implicit");                   fnOpts (NoImplicit : opts)@@ -479,6 +497,8 @@                  fnOpts (ErrorReverse : opts)       <|> do try (lchar '%' *> reserved "reflection");                   fnOpts (Reflection : opts)+      <|> do try (lchar '%' *> reserved "hint");+                  fnOpts (AutoHint : opts)       <|> do lchar '%'; reserved "specialise";              lchar '['; ns <- sepBy nameTimes (lchar ','); lchar ']'              fnOpts (Specialise ns : opts)@@ -486,8 +506,8 @@       <|> return opts       <?> "function modifier"   where nameTimes :: IdrisParser (Name, Maybe Int)-        nameTimes = do n <- fnName-                       t <- option Nothing (do reds <- natural+        nameTimes = do n <- fst <$> fnName+                       t <- option Nothing (do reds <- fmap fst natural                                                return (Just (fromInteger reds)))                        return (n, t) @@ -500,10 +520,11 @@ @ -} postulate :: SyntaxInfo -> IdrisParser PDecl-postulate syn = do doc <- try $ do (doc, _) <- docstring syn+postulate syn = do (doc, ext)+                       <- try $ do (doc, _) <- docstring syn                                    pushIndent-                                   reserved "postulate"-                                   return doc+                                   ext <- ppostDecl+                                   return (doc, ext)                    ist <- get                    let initOpts = if default_total ist                                      then [TotalFn]@@ -511,16 +532,17 @@                    opts <- fnOpts initOpts                    acc <- optional accessibility                    opts' <- fnOpts opts-                   n_in <- fnName+                   n_in <- fst <$> fnName                    let n = expandNS syn n_in                    lchar ':'                    ty <- typeExpr (allowImp syn)                    fc <- getFC                    terminator                    addAcc n acc-                   return (PPostulate doc syn fc opts' n ty)+                   return (PPostulate ext doc syn fc opts' n ty)                  <?> "postulate"-+   where ppostDecl = do reserved "postulate"; return False+                 <|> do lchar '%'; reserved "extern"; return True {- | Parses a using declaration  @@@ -550,12 +572,13 @@ params :: SyntaxInfo -> IdrisParser [PDecl] params syn =     do reserved "parameters"; lchar '('; ns <- typeDeclList syn; lchar ')'+       let ns' = [(n, ty) | (n, _, ty) <- ns]        openBlock        let pvars = syn_params syn-       ds <- many (decl syn { syn_params = pvars ++ ns })+       ds <- many (decl syn { syn_params = pvars ++ ns' })        closeBlock        fc <- getFC-       return [PParams fc ns (concat ds)]+       return [PParams fc ns' (concat ds)]     <?> "parameters declaration"  {- | Parses a mutual declaration (for mutually recursive functions)@@ -587,11 +610,12 @@ -} namespace :: SyntaxInfo -> IdrisParser [PDecl] namespace syn =-    do reserved "namespace"; n <- identifier;+    do reserved "namespace"+       (n, nfc) <- identifier        openBlock        ds <- some (decl syn { syn_namespace = n : syn_namespace syn })        closeBlock-       return [PNamespace n (concat ds)]+       return [PNamespace n nfc (concat ds)]      <?> "namespace declaration"  {- | Parses a methods block (for instances)@@ -619,18 +643,32 @@  @ ClassBlock ::=-  'where' OpenBlock MethodOrInstance* CloseBlock+  'where' OpenBlock Constructor? MethodOrInstance* CloseBlock   ; @ -}-classBlock :: SyntaxInfo -> IdrisParser [PDecl]+classBlock :: SyntaxInfo -> IdrisParser (Maybe (Name, FC), Docstring (Either Err PTerm), [PDecl]) classBlock syn = do reserved "where"                     openBlock+                    (cn, cd) <- option (Nothing, emptyDocstring) $+                                try (do (doc, _) <- option noDocs docComment+                                        n <- constructor+                                        return (Just n, doc))+                    ist <- get+                    let cd' = annotate syn ist cd+                     ds <- many (notEndBlock >> instance_ syn <|> fnDecl syn)                     closeBlock-                    return (concat ds)+                    return (cn, cd', concat ds)                  <?> "class block" +  where+    constructor :: IdrisParser (Name, FC)+    constructor = reserved "constructor" *> fnName++    annotate :: SyntaxInfo -> IState -> Docstring () -> Docstring (Either Err PTerm)+    annotate syn ist = annotCode $ tryFullExpr syn ist+ {-| Parses a type class declaration  @@@ -654,23 +692,25 @@                              return (doc, argDocs, acc))                 fc <- getFC                 cons <- constraintList syn-                n_in <- fnName+                let cons' = [(c, ty) | (c, _, ty) <- cons]+                (n_in, nfc) <- fnName                 let n = expandNS syn n_in                 cs <- many carg-                fds <- option (map fst cs) fundeps-                ds <- option [] (classBlock syn)+                fds <- option [(cn, NoFC) | (cn, _, _) <- cs] fundeps+                (cn, cd, ds) <- option (Nothing, fst noDocs, []) (classBlock syn)                 accData acc n (concatMap declared ds)-                return [PClass doc syn fc cons n cs argDocs fds ds]+                return [PClass doc syn fc cons' n nfc cs argDocs fds ds cn cd]              <?> "type-class declaration"   where-    fundeps :: IdrisParser [Name]+    fundeps :: IdrisParser [(Name, FC)]     fundeps = do lchar '|'; sepBy name (lchar ',') -    carg :: IdrisParser (Name, PTerm)-    carg = do lchar '('; i <- name; lchar ':'; ty <- expr syn; lchar ')'-              return (i, ty)-       <|> do i <- name;-              return (i, PType)+    carg :: IdrisParser (Name, FC, PTerm)+    carg = do lchar '('; (i, ifc) <- name; lchar ':'; ty <- expr syn; lchar ')'+              return (i, ifc, ty)+       <|> do (i, ifc) <- name+              fc <- getFC+              return (i, ifc, PType fc)  {- | Parses a type class instance declaration @@ -690,15 +730,16 @@                    fc <- getFC                    en <- optional instanceName                    cs <- constraintList syn-                   cn <- fnName+                   let cs' = [(c, ty) | (c, _, ty) <- cs]+                   (cn, cnfc) <- fnName                    args <- many (simpleExpr syn)-                   let sc = PApp fc (PRef fc cn) (map pexp args)+                   let sc = PApp fc (PRef cnfc cn) (map pexp args)                    let t = bindList (PPi constraint) cs sc                    ds <- option [] (instanceBlock syn)-                   return [PInstance doc argDocs syn fc cs cn args t en ds]+                   return [PInstance doc argDocs syn fc cs' cn cnfc args t en ds]                  <?> "instance declaration"   where instanceName :: IdrisParser Name-        instanceName = do lchar '['; n_in <- fnName; lchar ']'+        instanceName = do lchar '['; n_in <- fst <$> fnName; lchar ']'                           let n = expandNS syn n_in                           return n                        <?> "instance name"@@ -742,7 +783,7 @@ usingDeclList :: SyntaxInfo -> IdrisParser [Using] usingDeclList syn                = try (sepBy1 (usingDecl syn) (lchar ','))-             <|> do ns <- sepBy1 name (lchar ',')+             <|> do ns <- sepBy1 (fst <$> name) (lchar ',')                     lchar ':'                     t <- typeExpr (disallowImp syn)                     return (map (\x -> UImplicit x t) ns)@@ -758,12 +799,12 @@ @ -} usingDecl :: SyntaxInfo -> IdrisParser Using-usingDecl syn = try (do x <- fnName+usingDecl syn = try (do x <- fst <$> fnName                         lchar ':'                         t <- typeExpr (disallowImp syn)                         return (UImplicit x t))-            <|> do c <- fnName-                   xs <- some fnName+            <|> do c <- fst <$> fnName+                   xs <- some (fst <$> fnName)                    return (UConstraint c xs)             <?> "using declaration" @@ -787,7 +828,7 @@ -} caf :: SyntaxInfo -> IdrisParser PDecl caf syn = do reserved "let"-             n_in <- fnName; let n = expandNS syn n_in+             n_in <- fst <$> fnName; let n = expandNS syn n_in              lchar '='              t <- expr syn              terminator@@ -811,7 +852,7 @@ @ RHS ::= '='            Expr      |  '?='  RHSName? Expr-     |  'impossible'+     |  Impossible      ; @ @@ -823,11 +864,11 @@ rhs syn n = do lchar '='; expr syn         <|> do symbol "?=";                fc <- getFC-               name <- option n' (do symbol "{"; n <- fnName; symbol "}";+               name <- option n' (do symbol "{"; n <- fst <$> fnName; symbol "}";                                      return n)                r <- expr syn                return (addLet fc name r)-        <|> do reserved "impossible"; return PImpossible+        <|> impossible         <?> "function right hand side"   where mkN :: Name -> Name         mkN (UN x)   = if (tnull x || not (isAlpha (thead x)))@@ -837,10 +878,10 @@         n' :: Name         n' = mkN n         addLet :: FC -> Name -> PTerm -> PTerm-        addLet fc nm (PLet fc' n ty val r) = PLet fc' n ty val (addLet fc nm r)+        addLet fc nm (PLet fc' n nfc ty val r) = PLet fc' n nfc ty val (addLet fc nm r)         addLet fc nm (PCase fc' t cs) = PCase fc' t (map addLetC cs)           where addLetC (l, r) = (l, addLet fc nm r)-        addLet fc nm r = (PLet fc (sUN "value") Placeholder r (PMetavar nm))+        addLet fc nm r = (PLet fc (sUN "value") NoFC Placeholder r (PMetavar NoFC nm))  {- |Parses a function clause @@ -897,7 +938,7 @@                             symbol "<=="                             return ty)               fc <- getFC-              n_in <- fnName; let n = expandNS syn n_in+              n_in <- fst <$> fnName; let n = expandNS syn n_in               r <- rhs syn n               ist <- get               let ctxt = tt_ctxt ist@@ -907,20 +948,20 @@                                            return x,                                         do terminator                                            return ([], [])]-              let capp = PLet fc (sMN 0 "match")+              let capp = PLet fc (sMN 0 "match") NoFC                               ty                               (PMatchApp fc n)                               (PRef fc (sMN 0 "match"))               ist <- get               put (ist { lastParse = Just n })               return $ PClause fc n capp [] r wheres-       <|> do (l, op) <- try (do+       <|> do (l, op, nfc) <- try (do                 pushIndent                 l <- argExpr syn-                op <- operator+                (op, nfc) <- operatorFC                 when (op == "=" || op == "?=" ) $                      fail "infix clause definition with \"=\" and \"?=\" not supported "-                return (l, op))+                return (l, op, nfc))               let n = expandNS syn (sUN op)               r <- argExpr syn               fc <- getFC@@ -933,7 +974,7 @@                                             do terminator                                                return ([], [])]                   ist <- get-                  let capp = PApp fc (PRef fc n) [pexp l, pexp r]+                  let capp = PApp fc (PRef nfc n) [pexp l, pexp r]                   put (ist { lastParse = Just n })                   return $ PClause fc n capp wargs rs wheres) <|> (do                    popIndent@@ -949,13 +990,13 @@                    put (ist { lastParse = Just n })                    return $ PWith fc n capp wargs wval pn withs)        <|> do pushIndent-              n_in <- fnName; let n = expandNS syn n_in+              (n_in, nfc) <- fnName; let n = expandNS syn n_in               cargs <- many (constraintArg syn)               fc <- getFC               args <- many (try (implicitArg (syn { inPattern = True } ))                             <|> (fmap pexp (argExpr syn)))               wargs <- many (wExpr syn)-              let capp = PApp fc (PRef fc n)+              let capp = PApp fc (PRef nfc n)                            (cargs ++ args)               (do r <- rhs syn n                   ist <- get@@ -1036,7 +1077,8 @@ @ -} codegen_ :: IdrisParser Codegen-codegen_ = do n <- identifier; return (Via (map toLower n))+codegen_ = do n <- fst <$> identifier+              return (Via (map toLower n))        <|> do reserved "Bytecode"; return Bytecode        <?> "code generation language" @@ -1071,72 +1113,53 @@ @ -} directive :: SyntaxInfo -> IdrisParser [PDecl]-directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- stringLiteral;-                   return [PDirective (do addLib cgn lib-                                          addIBC (IBCLib cgn lib))]-             <|> do try (lchar '%' *> reserved "link"); cgn <- codegen_; obj <- stringLiteral;-                    return [PDirective (do dirs <- allImportDirs-                                           o <- liftIO $ findInPath dirs obj-                                           addIBC (IBCObj cgn obj) -- just name, search on loading ibc-                                           addObjectFile cgn o)]-             <|> do try (lchar '%' *> reserved "flag"); cgn <- codegen_;-                    flag <- stringLiteral-                    return [PDirective (do addIBC (IBCCGFlag cgn flag)-                                           addFlag cgn flag)]-             <|> do try (lchar '%' *> reserved "include"); cgn <- codegen_; hdr <- stringLiteral;-                    return [PDirective (do addHdr cgn hdr-                                           addIBC (IBCHeader cgn hdr))]-             <|> do try (lchar '%' *> reserved "hide"); n <- fnName-                    return [PDirective (do setAccessibility n Hidden-                                           addIBC (IBCAccess n Hidden))]-             <|> do try (lchar '%' *> reserved "freeze"); n <- iName []-                    return [PDirective (do setAccessibility n Frozen-                                           addIBC (IBCAccess n Frozen))]+directive syn = do try (lchar '%' *> reserved "lib")+                   cgn <- codegen_+                   lib <- fmap fst stringLiteral+                   return [PDirective (DLib cgn lib)]+             <|> do try (lchar '%' *> reserved "link")+                    cgn <- codegen_; obj <- fst <$> stringLiteral+                    return [PDirective (DLink cgn obj)]+             <|> do try (lchar '%' *> reserved "flag")+                    cgn <- codegen_; flag <- fst <$> stringLiteral+                    return [PDirective (DFlag cgn flag)]+             <|> do try (lchar '%' *> reserved "include")+                    cgn <- codegen_+                    hdr <- fst <$> stringLiteral+                    return [PDirective (DInclude cgn hdr)]+             <|> do try (lchar '%' *> reserved "hide"); n <- fst <$> fnName+                    return [PDirective (DHide n)]+             <|> do try (lchar '%' *> reserved "freeze"); n <- fst <$> iName []+                    return [PDirective (DFreeze n)]              <|> do try (lchar '%' *> reserved "access"); acc <- accessibility-                    return [PDirective (do i <- get-                                           put(i { default_access = acc }))]+                    return [PDirective (DAccess acc)]              <|> do try (lchar '%' *> reserved "default"); tot <- totality                     i <- get                     put (i { default_total = tot } )-                    return [PDirective (do i <- get-                                           put(i { default_total = tot }))]-             <|> do try (lchar '%' *> reserved "logging"); i <- natural;-                    return [PDirective (setLogLevel (fromInteger i))]-             <|> do try (lchar '%' *> reserved "dynamic"); libs <- sepBy1 stringLiteral (lchar ',');-                    return [PDirective (do added <- addDyLib libs-                                           case added of-                                             Left lib -> addIBC (IBCDyLib (lib_name lib))-                                             Right msg ->-                                                 fail $ msg)]+                    return [PDirective (DDefault tot)]+             <|> do try (lchar '%' *> reserved "logging")+                    i <- fst <$> natural+                    return [PDirective (DLogging i)]+             <|> do try (lchar '%' *> reserved "dynamic")+                    libs <- sepBy1 (fmap fst stringLiteral) (lchar ',')+                    return [PDirective (DDynamicLibs libs)]              <|> do try (lchar '%' *> reserved "name")-                    ty <- fnName-                    ns <- sepBy1 name (lchar ',')-                    return [PDirective (do ty' <- disambiguate ty-                                           mapM_ (addNameHint ty') ns-                                           mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns)]+                    ty <- fst <$> fnName+                    ns <- sepBy1 (fst <$> name) (lchar ',')+                    return [PDirective (DNameHint ty ns)]              <|> do try (lchar '%' *> reserved "error_handlers")-                    fn <- fnName-                    arg <- fnName-                    ns <- sepBy1 name (lchar ',')-                    return [PDirective (do fn' <- disambiguate fn-                                           ns' <- mapM disambiguate ns-                                           addFunctionErrorHandlers fn' arg ns'-                                           mapM_ (addIBC . IBCFunctionErrorHandler fn' arg) ns')]+                    fn <- fst <$> fnName+                    arg <- fst <$> fnName+                    ns <- sepBy1 (fst <$> name) (lchar ',')+                    return [PDirective (DErrorHandlers fn arg ns) ]              <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;-                    return [PDirective (addLangExt ext)]+                    return [PDirective (DLanguage ext)]              <|> do fc <- getFC                     try (lchar '%' *> reserved "used")-                    fn <- fnName-                    arg <- iName []-                    return [PDirective (addUsedName fc fn arg)]-+                    fn <- fst <$> fnName+                    arg <- fst <$> iName []+                    return [PDirective (DUsed fc fn arg)]              <?> "directive"-  where disambiguate :: Name -> Idris Name-        disambiguate n = do i <- getIState-                            case lookupCtxtName n (idris_implicits i) of-                              [(n', _)] -> return n'-                              []        -> throwError (NoSuchVariable n)-                              more      -> throwError (CantResolveAlts (map fst more))  pLangExt :: IdrisParser LanguageExt pLangExt = (reserved "TypeProviders" >> return TypeProviders)@@ -1169,14 +1192,14 @@                   provideTerm doc <|> providePostulate doc                <?> "type provider"   where provideTerm doc =-          do lchar '('; n <- fnName; lchar ':'; t <- typeExpr syn; lchar ')'+          do lchar '('; n <- fst <$> fnName; lchar ':'; t <- typeExpr syn; lchar ')'              fc <- getFC              reserved "with"              e <- expr syn <?> "provider expression"              return  [PProvider doc syn fc (ProvTerm t e) n]         providePostulate doc =           do reserved "postulate"-             n <- fnName+             n <- fst <$> fnName              fc <- getFC              reserved "with"              e <- expr syn <?> "provider expression"@@ -1209,23 +1232,29 @@  {- | Parses a constant form input -} parseConst :: IState -> String -> Result Const-parseConst st = runparser constant st "(input)"+parseConst st = runparser (fmap fst constant) st "(input)"  {- | Parses a tactic from input -} parseTactic :: IState -> String -> Result PTactic parseTactic st = runparser (fullTactic defaultSyntax) st "(input)"  -- | Parse module header and imports-parseImports :: FilePath -> String -> Idris (Maybe (Docstring ()), [String], [(Bool, String, Maybe String, FC)], Maybe Delta)+parseImports :: FilePath -> String -> Idris (Maybe (Docstring ()), [String], [ImportInfo], Maybe Delta) parseImports fname input     = do i <- getIState          case parseString (runInnerParser (evalStateT imports i)) (Directed (UTF8.fromString fname) 0 0 0 0) input of-              Failure err    -> fail (show err)-              Success (x, i) -> do putIState i-                                   return x-  where imports :: IdrisParser ((Maybe (Docstring ()), [String], [(Bool, String, Maybe String, FC)], Maybe Delta), IState)+              Failure err -> fail (show err)+              Success (x, annots, i) ->+                do putIState i+                   fname' <- runIO $ Dir.makeAbsolute fname+                   sendHighlighting $ addPath annots fname'+                   return x+  where imports :: IdrisParser ((Maybe (Docstring ()), [String],+                                 [ImportInfo],+                                 Maybe Delta),+                                [(FC, OutputAnnotation)], IState)         imports = do whiteSpace-                     (mdoc, mname) <- moduleHeader+                     (mdoc, mname, annots) <- moduleHeader                      ps            <- many import_                      mrk           <- mark                      isEof         <- lookAheadMatches eof@@ -1233,7 +1262,12 @@                                    then Nothing                                    else Just mrk                      i     <- get-                     return ((mdoc, mname, ps, mrk'), i)+                     return ((mdoc, mname, ps, mrk'), annots, i)+        addPath :: [(FC, OutputAnnotation)] -> FilePath -> [(FC, OutputAnnotation)]+        addPath [] _ = []+        addPath ((fc, AnnNamespace ns Nothing) : annots) path =+           (fc, AnnNamespace ns (Just path)) : addPath annots path+        addPath (annot:annots) path = annot : addPath annots path  -- | There should be a better way of doing this... findFC :: Doc -> (FC, String)@@ -1341,27 +1375,44 @@              = do iLOG ("Reading " ++ f)                   i <- getIState                   let def_total = default_total i-                  file_in <- runIO $ readFile f+                  file_in <- runIO $ readSource f                   file <- if lidr then tclift $ unlit f file_in else return file_in                   (mdocs, mname, imports_in, pos) <- parseImports f file                   ai <- getAutoImports-                  let imports = map (\n -> (True, n, Just n, emptyFC)) ai ++ imports_in+                  let imports = map (\n -> ImportInfo True n Nothing [] NoFC NoFC) ai ++ imports_in                   ids <- allImportDirs                   ibcsd <- valIBCSubDir i-                  mapM_ (\(re, f) ->+                  mapM_ (\(re, f, ns, nfc) ->                                do fp <- findImport ids ibcsd f                                   case fp of                                       LIDR fn -> ifail $ "No ibc for " ++ f                                       IDR fn -> ifail $ "No ibc for " ++ f-                                      IBC fn src -> loadIBC True fn)-                        [(re, fn) | (re, fn, _, _) <- imports]+                                      IBC fn src ->+                                        do loadIBC True fn+                                           let srcFn = case src of+                                                         IDR fn -> Just fn+                                                         LIDR fn -> Just fn+                                                         _ -> Nothing+                                           srcFnAbs <- case srcFn of+                                                         Just fn -> fmap Just (runIO $ Dir.makeAbsolute fn)+                                                         Nothing -> return Nothing+                                           sendHighlighting [(nfc, AnnNamespace ns srcFnAbs)])+                        [(re, fn, ns, nfc) | ImportInfo re fn _ ns _ nfc <- imports]                   reportParserWarnings                    -- process and check module aliases                   let modAliases = M.fromList-                        [(prep alias, prep realName) | (reexport, realName, Just alias, fc) <- imports]-                      prep = map T.pack . reverse . Spl.splitOn "/"-                      aliasNames = [(alias, fc) | (_, _, Just alias, fc) <- imports]+                        [ (prep alias, prep realName)+                        | ImportInfo { import_reexport = reexport+                                     , import_path = realName+                                     , import_rename = Just (alias, _)+                                     , import_location = fc } <- imports+                        ]+                      prep = map T.pack . reverse . Spl.splitOn [pathSeparator]+                      aliasNames = [ (alias, fc)+                                   | ImportInfo { import_rename = Just (alias, _)+                                                , import_location = fc } <- imports+                                   ]                       histogram = groupBy ((==) `on` fst) . sortBy (comparing fst) $ aliasNames                   case map head . filter ((/= 1) . length) $ histogram of                     []       -> logLvl 3 $ "Module aliases: " ++ show (M.toList modAliases)@@ -1373,7 +1424,12 @@                   -- record package info in .ibc                   imps <- allImportDirs                   mapM_ addIBC (map IBCImportDir imps)-                  mapM_ (addIBC . IBCImport) [(reexport, realName) | (reexport, realName, alias, fc) <- imports]+                  mapM_ (addIBC . IBCImport)+                    [ (reexport, realName)+                    | ImportInfo { import_reexport = reexport+                                 , import_path = realName+                                 } <- imports+                    ]                   let syntax = defaultSyntax{ syn_namespace = reverse mname,                                               maxline = toline }                   ist <- getIState@@ -1457,15 +1513,16 @@   where     namespaces :: [String] -> [PDecl] -> [PDecl]     namespaces []     ds = ds-    namespaces (x:xs) ds = [PNamespace x (namespaces xs ds)]+    namespaces (x:xs) ds = [PNamespace x NoFC (namespaces xs ds)]      toMutual :: PDecl -> PDecl     toMutual m@(PMutual _ d) = m-    toMutual (PNamespace x ds) = PNamespace x (map toMutual ds)+    toMutual (PNamespace x fc ds) = PNamespace x fc (map toMutual ds)     toMutual x = let r = PMutual (fileFC "single mutual") [x] in                  case x of                    PClauses{} -> r                    PClass{} -> r+                   PData{} -> r                    PInstance{} -> r                    _ -> x
src/Idris/PartialEval.hs view
@@ -128,12 +128,12 @@ mkPE_TyDecl ist args ty = mkty args ty   where     mkty ((ExplicitD, v) : xs) (Bind n (Pi _ t k) sc)-       = PPi expl n (delab ist (generaliseIn t)) (mkty xs sc)+       = PPi expl n NoFC (delab ist (generaliseIn t)) (mkty xs sc)     mkty ((ImplicitD, v) : xs) (Bind n (Pi _ t k) sc)          | concreteClass ist t = mkty xs sc          | classConstraint ist t -             = PPi constraint n (delab ist (generaliseIn t)) (mkty xs sc)-         | otherwise = PPi impl n (delab ist (generaliseIn t)) (mkty xs sc)+             = PPi constraint n NoFC (delab ist (generaliseIn t)) (mkty xs sc)+         | otherwise = PPi impl n NoFC (delab ist (generaliseIn t)) (mkty xs sc)      mkty (_ : xs) t        = mkty xs t@@ -146,7 +146,7 @@         = do nm <- get              put (nm + 1)              return (P Bound (sMN nm "spec") Erased)-    gen (App f a) = App <$> gen f <*> gen a+    gen (App s f a) = App s <$> gen f <*> gen a     gen tm = return tm  -- | Checks if a given argument is a type class constraint argument@@ -291,7 +291,7 @@      -- if we have a *defined* function that has static arguments,     -- it will become a specialised application-    ga env tm@(App f a) | (P _ n _, args) <- unApply tm,+    ga env tm@(App _ f a) | (P _ n _, args) <- unApply tm,                           n `notElem` map fst (idris_metavars ist) =         ga env f ++ ga env a ++           case (lookupCtxtExact n (idris_statics ist),
src/Idris/Primitives.hs view
@@ -13,7 +13,6 @@ import Data.Int import Data.Char import Data.Function (on)-import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V  data Prim = Prim { p_name  :: Name,@@ -125,7 +124,7 @@    Prim (sUN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)      (1, LChInt ITNative) total,    Prim (sUN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)-     (1, LIntCh ITNative) total,+     (1, LIntCh ITNative) partial,    Prim (sUN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)      (1, LStrFloat) total,    Prim (sUN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)@@ -167,44 +166,14 @@    Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)     (1, LStrRev) total, -   Prim (sUN "prim__readFile") (ty [WorldType,PtrType] StrType) 2 (p_cantreduce)-     (2, LReadFile) total, -- total is okay, because we have 'WorldType'-   Prim (sUN "prim__writeFile") (ty [WorldType,PtrType,StrType] (AType (ATInt ITNative))) 3 (p_cantreduce)-     (3, LWriteFile) total,    Prim (sUN "prim__readString") (ty [WorldType] StrType) 1 (p_cantreduce)      (1, LReadStr) total, -- total is okay, because we have 'WorldType'    Prim (sUN "prim__writeString") (ty [WorldType,StrType] (AType (ATInt ITNative))) 2 (p_cantreduce)      (2, LWriteStr) total,--   Prim (sUN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)-     (0, LVMPtr) total,-   -- Streams-   Prim (sUN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)-    (0, LStdIn) total,-   Prim (sUN "prim__stdout") (ty [] PtrType) 0 (p_cantreduce)-    (0, LStdOut) total,-   Prim (sUN "prim__stderr") (ty [] PtrType) 0 (p_cantreduce)-    (0, LStdErr) total,-   Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce)-    (0, LNullPtr) total,-   -- Managed pointer registration-   Prim (sUN "prim__registerPtr") (ty [PtrType, AType (ATInt ITNative)] ManagedPtrType) 2 (p_cantreduce)-    (2, LRegisterPtr) total,-   -- Buffers-   Prim (sUN "prim__allocate") (ty [AType (ATInt (ITFixed IT64))] BufferType) 1 (p_allocate)-    (1, LAllocate) total,-   Prim (sUN "prim__appendBuffer") (ty [BufferType, AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), BufferType] BufferType) 6 (p_appendBuffer)-    (6, LAppendBuffer) partial,     Prim (sUN "prim__systemInfo") (ty [AType (ATInt ITNative)] StrType) 1 (p_cantreduce)         (1, LSystemInfo) total   ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]-    ++ concatMap vecOps vecTypes-    ++ concatMap fixedOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64] -- ITNative, ITChar, ATFloat ] ++ vecTypes-    ++ vecBitcasts vecTypes -vecTypes :: [IntTy]-vecTypes = [ITVec IT8 16, ITVec IT16 8, ITVec IT32 4, ITVec IT64 2]- intOps :: IntTy -> [Prim] intOps ity = intCmps ity ++ intArith ity ++ intConv ity @@ -257,67 +226,11 @@                (1, LFloatInt ity) total     ] -vecCmps :: IntTy -> [Prim]-vecCmps ity =-    [ iCmp ity "slt" True (bCmp ity (<)) (LSLt . ATInt) total-    , iCmp ity "slte" True (bCmp ity (<=)) (LSLe . ATInt) total-    , iCmp ity "eq" True (bCmp ity (==)) (LEq . ATInt) total-    , iCmp ity "sgte" True (bCmp ity (>=)) (LSGe . ATInt) total-    , iCmp ity "sgt" True (bCmp ity (>)) (LSGt . ATInt) total-    , iCmp ity "lt" True (bCmp ity (<)) LLt total-    , iCmp ity "lte" True (bCmp ity (<=)) LLe total-    , iCmp ity "gte" True (bCmp ity (>=)) LGe total-    , iCmp ity "gt" True (bCmp ity (>)) LGt total-    ]---- The TODOs in this function are documented as Issue #1617 on the issue tracker.------     https://github.com/idris-lang/Idris-dev/issues/1617-vecOps :: IntTy -> [Prim]-vecOps ity@(ITVec elem count) =-    [ Prim (sUN $ "prim__mk" ++ intTyName ity)-               (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))-               count (mkVecCon elem count) (count, LMkVec elem count) total-    , Prim (sUN $ "prim__index" ++ intTyName ity)-               (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32))] (AType . ATInt . ITFixed $ elem))-               2 (mkVecIndex count) (2, LIdxVec elem count) partial -- TODO: Ensure this reduces-    , Prim (sUN $ "prim__update" ++ intTyName ity)-               (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32)), AType . ATInt . ITFixed $ elem]-                       (AType . ATInt $ ity))-               3 (mkVecUpdate elem count) (3, LUpdateVec elem count) partial -- TODO: Ensure this reduces-    ] ++ intArith ity ++ vecCmps ity- bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim bitcastPrim from to impl prim =     Prim (sUN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)          (1, prim) total -vecBitcasts :: [IntTy] -> [Prim]-vecBitcasts tys = [bitcastPrim from to bitcastVec (LBitCast from to)-                       | from <- map ATInt vecTypes, to <- map ATInt vecTypes, from /= to]--fixedOps :: IntTy -> [Prim]-fixedOps ity@(ITFixed _) =-    map appendFun endiannesses ++-    map peekFun endiannesses-    where-      endiannesses = [ Native, LE, BE ]-      tyName = intTyName ity-      b64 = AType (ATInt (ITFixed IT64))-      thisTy = AType $ ATInt ity-      appendFun en = Prim (sUN $ "prim__append" ++ tyName ++ show en)-                         (ty [BufferType, b64, b64, thisTy] BufferType)-                         4 (p_append en) (4, LAppend ity en) partial-      peekFun en = Prim (sUN $ "prim__peek" ++ tyName ++ show en)-                         (ty [BufferType, b64] thisTy)-                         2 (p_peek ity en) (2, LPeek ity en) partial--mapHalf :: (V.Unbox a, V.Unbox b) => ((a, a) -> b) -> Vector a -> Vector b-mapHalf f xs = V.generate (V.length xs `div` 2) (\i -> f (xs V.! (i*2), xs V.! (i*2+1)))--mapDouble :: (V.Unbox a, V.Unbox b) => (Bool -> a -> b) -> Vector a -> Vector b-mapDouble f xs = V.generate (V.length xs * 2) (\i -> f (i `rem` 2 == 0) (xs V.! (i `div` 2)))- concatWord8 :: (Word8, Word8) -> Word16 concatWord8 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 8) @@ -339,76 +252,6 @@ truncWord64 True x = fromIntegral (x `shiftR` 32) truncWord64 False x = fromIntegral x -bitcastVec :: ArithTy -> [Const] -> Maybe Const-bitcastVec (ATInt (ITVec IT8  n)) [x@(B8V v)]-    | V.length v == n = Just x-bitcastVec (ATInt (ITVec IT16 n))   [B8V v]-    | V.length v == n*2 = Just . B16V . mapHalf concatWord8 $ v-bitcastVec (ATInt (ITVec IT32 n))   [B8V v]-    | V.length v == n*4 = Just . B32V . mapHalf concatWord16 . mapHalf concatWord8 $ v-bitcastVec (ATInt (ITVec IT64 n))   [B8V v]-    | V.length v == n*8 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 . mapHalf concatWord8 $ v--bitcastVec (ATInt (ITVec IT8  n))   [B16V v]-    | V.length v * 2 == n = Just . B8V . mapDouble truncWord16 $ v-bitcastVec (ATInt (ITVec IT16 n)) [x@(B16V v)]-    | V.length v == n = Just x-bitcastVec (ATInt (ITVec IT32 n))   [B16V v]-    | V.length v == n*2 = Just . B32V . mapHalf concatWord16 $ v-bitcastVec (ATInt (ITVec IT64 n))   [B16V v]-    | V.length v == n*4 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 $ v--bitcastVec (ATInt (ITVec IT8  n))   [B32V v]-    | V.length v * 4 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 $ v-bitcastVec (ATInt (ITVec IT16 n))   [B32V v]-    | V.length v * 2 == n = Just . B16V . mapDouble truncWord32 $ v-bitcastVec (ATInt (ITVec IT32 n)) [x@(B32V v)]-    | V.length v == n = Just x-bitcastVec (ATInt (ITVec IT64 n))   [B32V v]-    | V.length v == n*2 = Just . B64V . mapHalf concatWord32 $ v--bitcastVec (ATInt (ITVec IT8  n))   [B64V v]-    | V.length v * 8 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 . mapDouble truncWord64 $ v-bitcastVec (ATInt (ITVec IT16 n))   [B64V v]-    | V.length v * 4 == n = Just . B16V . mapDouble truncWord32 . mapDouble truncWord64 $ v-bitcastVec (ATInt (ITVec IT32 n))   [B64V v]-    | V.length v == n*2 = Just . B32V . mapDouble truncWord64 $ v-bitcastVec (ATInt (ITVec IT64 n)) [x@(B64V v)]-    | V.length v == n = Just x--bitcastVec _ _ = Nothing--mkVecCon :: NativeTy -> Int -> [Const] -> Maybe Const-mkVecCon ity count args-    | length ints == count = Just (mkVec ity count ints)-    | otherwise = Nothing-    where-      ints = getInt args-      mkVec :: NativeTy -> Int -> [Integer] -> Const-      mkVec IT8  len values = B8V  $ V.generate len (fromInteger . (values !!))-      mkVec IT16 len values = B16V $ V.generate len (fromInteger . (values !!))-      mkVec IT32 len values = B32V $ V.generate len (fromInteger . (values !!))-      mkVec IT64 len values = B64V $ V.generate len (fromInteger . (values !!))--mkVecIndex count [vec, B32 i] = Just (idxVec vec)-    where-      idxVec :: Const -> Const-      idxVec (B8V  v) = B8  $ V.unsafeIndex v (fromIntegral i)-      idxVec (B16V v) = B16 $ V.unsafeIndex v (fromIntegral i)-      idxVec (B32V v) = B32 $ V.unsafeIndex v (fromIntegral i)-      idxVec (B64V v) = B64 $ V.unsafeIndex v (fromIntegral i)-mkVecIndex _ _ = Nothing--mkVecUpdate ity count [vec, B32 i, newElem] = updateVec vec newElem-    where-      updateVec :: Const -> Const -> Maybe Const-      updateVec (B8V  v) (B8  e) = Just . B8V  $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))-      updateVec (B16V v) (B16 e) = Just . B16V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))-      updateVec (B32V v) (B32 e) = Just . B32V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))-      updateVec (B64V v) (B64 e) = Just . B64V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))-      updateVec _ _ = Nothing-mkVecUpdate _ _ _ = Nothing- aTyName :: ArithTy -> String aTyName (ATInt t) = intTyName t aTyName ATFloat = "Float"@@ -470,18 +313,6 @@     = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64)) bsrem ITNative [I x, I y] = Just $ I (x `rem` y) bsrem ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `rem` (ord y))-bsrem (ITVec IT8  _) [B8V  x, B8V  y]-    = Just . B8V  $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int8)))  x y-bsrem (ITVec IT16 _) [B16V x, B16V y]-    = Just . B16V $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int16))) x y-bsrem (ITVec IT32 _) [B32V x, B32V y]-    = Just . B32V $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y-bsrem (ITVec IT64 _) [B64V x, B64V y]-    = Just . B64V $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y bsrem _ _ = Nothing  bsdiv :: IntTy -> [Const] -> Maybe Const@@ -496,18 +327,6 @@     = Just $ B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64)) bsdiv ITNative [I x, I y] = Just $ I (x `div` y) bsdiv ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `div` (ord y))-bsdiv (ITVec IT8  _) [B8V  x, B8V  y]-    = Just . B8V  $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int8)))  x y-bsdiv (ITVec IT16 _) [B16V x, B16V y]-    = Just . B16V $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int16))) x y-bsdiv (ITVec IT32 _) [B32V x, B32V y]-    = Just . B32V $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y-bsdiv (ITVec IT64 _) [B64V x, B64V y]-    = Just . B64V $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y bsdiv _ _ = Nothing  bashr :: IntTy -> [Const] -> Maybe Const@@ -522,18 +341,6 @@     = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64)) bashr ITNative [I x, I y] = Just $ I (x `shiftR` y) bashr ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `shiftR` (ord y))-bashr (ITVec IT8  _) [B8V  x, B8V  y]-    = Just . B8V  $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int8)))  x y-bashr (ITVec IT16 _) [B16V x, B16V y]-    = Just . B16V $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int16))) x y-bashr (ITVec IT32 _) [B32V x, B32V y]-    = Just . B32V $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y-bashr (ITVec IT64 _) [B64V x, B64V y]-    = Just . B64V $-      V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y bashr _ _ = Nothing  bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const@@ -544,10 +351,6 @@ bUn ITBig    op [BI x]  = Just $ BI (op x) bUn ITNative op [I x]   = Just $ I (op x) bUn ITChar op [Ch x] = Just $ Ch (chr $ op (ord x))-bUn (ITVec IT8  _) op [B8V  x] = Just . B8V  $ V.map op x-bUn (ITVec IT16 _) op [B16V x] = Just . B16V $ V.map op x-bUn (ITVec IT32 _) op [B32V x] = Just . B32V $ V.map op x-bUn (ITVec IT64 _) op [B64V x] = Just . B64V $ V.map op x bUn _        _   _      = Nothing  bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const@@ -558,10 +361,6 @@ bitBin ITBig    op [BI x,  BI y]  = Just $ BI (op x y) bitBin ITNative op [I x,   I y]   = Just $ I (op x y) bitBin ITChar   op [Ch x,  Ch y]   = Just $ Ch (chr $ op (ord x) (ord y))-bitBin (ITVec IT8  _) op [B8V  x, B8V  y] = Just . B8V  $ V.zipWith op x y-bitBin (ITVec IT16 _) op [B16V x, B16V y] = Just . B16V $ V.zipWith op x y-bitBin (ITVec IT32 _) op [B32V x, B32V y] = Just . B32V $ V.zipWith op x y-bitBin (ITVec IT64 _) op [B64V x, B64V y] = Just . B64V $ V.zipWith op x y bitBin _        _  _              = Nothing  bCmp :: IntTy -> (forall a. (Integral a, Ord a) => a -> a -> Bool) -> [Const] -> Maybe Const@@ -572,14 +371,6 @@ bCmp ITBig    op [BI x, BI y]   = Just $ I (if (op x y) then 1 else 0) bCmp ITNative op [I x, I y]     = Just $ I (if (op x y) then 1 else 0) bCmp ITChar   op [Ch x, Ch y]     = Just $ I (if (op (ord x) (ord y)) then 1 else 0)-bCmp (ITVec IT8 _)  op [B8V  x, B8V  y]-    = Just . B8V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y-bCmp (ITVec IT16 _) op [B16V x, B16V y]-    = Just . B16V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y-bCmp (ITVec IT32 _) op [B32V x, B32V y]-    = Just . B32V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y-bCmp (ITVec IT64 _) op [B64V x, B64V y]-    = Just . B64V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y bCmp _        _  _              = Nothing  @@ -716,54 +507,6 @@ p_strCons _ = Nothing p_strRev [Str xs] = Just $ Str (reverse xs) p_strRev _ = Nothing--p_allocate, p_appendBuffer :: [Const] -> Maybe Const-p_allocate [B64 _] = Just $ B8V V.empty-p_allocate n = Nothing-p_appendBuffer [B8V vect1, B64 size1, B64 count, B64 size2, B64 off, B8V vect2] =-    Just $ B8V (foldl (V.++)-                      (V.slice 0 (fromIntegral size1) vect1)-                      (replicate (fromIntegral count) (V.slice (fromIntegral off) (fromIntegral size2) vect2)))-p_appendBuffer n = Nothing-p_append :: Endianness -> [Const] -> Maybe Const-p_append en [B8V vect, B64 size, B64 count, val] =-    let bytes = case val of-                  B8 x -> [x]-                  B16 x -> [fromIntegral x, fromIntegral (shiftR x 8)]-                  B32 x -> map (fromIntegral . shiftR x) [0,8..24]-                  B64 x -> map (fromIntegral . shiftR x) [0,8..56]-    in Just $ B8V (foldl V.snoc-                         (V.slice 0 (fromIntegral size) vect)-                         (concat (replicate (fromIntegral count)-                                            (case en of-                                               BE -> reverse bytes-                                               _  -> bytes))))-p_append _ _ = Nothing--p_peek :: IntTy -> Endianness -> [Const] -> Maybe Const-p_peek (ITFixed IT8)  _ [B8V vect, B64 offset] = Just $ B8 (vect V.! fromIntegral offset)-p_peek (ITFixed IT16) en [B8V vect, B64 offset] =-    let bytes = [0..1]-    in Just $ B16 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))-                         0-                         (case en of-                            BE -> bytes-                            _  -> reverse bytes))-p_peek (ITFixed IT32) en [B8V vect, B64 offset] =-    let bytes = [0..1]-    in Just $ B32 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))-                         0-                         (case en of-                            BE -> bytes-                            _  -> reverse bytes))-p_peek (ITFixed IT64) en [B8V vect, B64 offset] =-    let bytes = [0..1]-    in Just $ B64 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))-                         0-                         (case en of-                            BE -> bytes-                            _  -> reverse bytes))-p_peek _ _ _ = Nothing  p_cantreduce :: a -> Maybe b p_cantreduce _ = Nothing
src/Idris/ProofSearch.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} -module Idris.ProofSearch(trivial, proofSearch) where+module Idris.ProofSearch(trivial, trivialHoles, proofSearch) where  import Idris.Core.Elaborate hiding (Tactic(..)) import Idris.Core.TT@@ -15,13 +15,18 @@ import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.State.Strict+import qualified Data.Set as S import Data.List import Debug.Trace  -- Pass in a term elaborator to avoid a cyclic dependency with ElabTerm  trivial :: (PTerm -> ElabD ()) -> IState -> ElabD ()-trivial elab ist = try' (do elab (PRefl (fileFC "prf") Placeholder)+trivial = trivialHoles []++trivialHoles :: [(Name, Int)] -> (PTerm -> ElabD ()) -> IState -> ElabD ()+trivialHoles ok elab ist +                 = try' (do elab (PApp (fileFC "prf") (PRef (fileFC "prf") eqCon) [pimp (sUN "A") Placeholder False, pimp (sUN "x") Placeholder False])                             return ())                         (do env <- get_env                             g <- goal@@ -32,12 +37,29 @@         tryAll ((x, b):xs)            = do -- if type of x has any holes in it, move on                 hs <- get_holes+                let badhs = hs -- filter (flip notElem holesOK) hs                 g <- goal-                if all (\n -> not (n `elem` hs)) (freeNames (binderTy b))+                -- anywhere but the top is okay for a hole, if holesOK set+                if -- all (\n -> not (n `elem` badhs)) (freeNames (binderTy b))+                   holesOK hs (binderTy b)                    then try' (elab (PRef (fileFC "prf") x))                              (tryAll xs) True                    else tryAll xs+        +        holesOK hs ap@(App _ _ _)+           | (P _ n _, args) <- unApply ap+                = holeArgsOK hs n 0 args+        holesOK hs (App _ f a) = holesOK hs f && holesOK hs a+        holesOK hs (P _ n _) = not (n `elem` hs)+        holesOK hs (Bind n b sc) = holesOK hs (binderTy b) && +                                   holesOK hs sc+        holesOK hs _ = True +        holeArgsOK hs n p [] = True+        holeArgsOK hs n p (a : as)+           | (n, p) `elem` ok = holeArgsOK hs n (p + 1) as+           | otherwise = holesOK hs a && holeArgsOK hs n (p + 1) as+ cantSolveGoal :: ElabD a cantSolveGoal = do g <- goal                    env <- get_env@@ -87,22 +109,32 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist         = do compute             ty <- goal+            hs <- get_holes+            env <- get_env+            tm <- get_term             argsok <- conArgsOK ty             if ambigok || argsok then                case lookupCtxt nroot (idris_tyinfodata ist) of                     [TISolution ts] -> findInferredTy ts-                    _ -> psRec rec maxDepth-               else autoArg (sUN "auto") -- not enough info in the type yet+                    _ -> psRec rec maxDepth [] S.empty+               else do ptm <- get_term+                       autoArg (sUN "auto") -- not enough info in the type yet   where     findInferredTy (t : _) = elab (delab ist (toUN t))       conArgsOK ty        = let (f, as) = unApply ty in-         case f of-              P _ n _ -> case lookupCtxt n (idris_datatypes ist) of-                              [t] -> do rs <- mapM (conReady as) (con_names t)-                                        return (and rs)-                              _ -> fail "Ambiguous name"+           case f of+              P _ n _ -> +                let autohints = case lookupCtxtExact n (idris_autohints ist) of+                                     Nothing -> []+                                     Just hs -> hs in+                    case lookupCtxtExact n (idris_datatypes ist) of+                              Just t -> do rs <- mapM (conReady as) +                                                      (autohints ++ con_names t)+                                           return (and rs)+                              Nothing -> -- local variable, go for it+                                    return True               TType _ -> return True               _ -> fail "Not a data type" @@ -126,15 +158,28 @@     toUN t@(P nt (MN i n) ty)         | ('_':xs) <- str n = t        | otherwise = P nt (UN n) ty-    toUN (App f a) = App (toUN f) (toUN a)+    toUN (App s f a) = App s (toUN f) (toUN a)     toUN t = t -    psRec _ 0 | fromProver = cantSolveGoal-    psRec rec 0 = do attack; defer [] nroot; solve --fail "Maximum depth reached"-    psRec False d = tryCons d hints -    psRec True d = do compute+    -- psRec counts depth and the local variable applications we're under+    -- (so we don't try a pointless application of something to itself,+    -- which obviously won't work anyway but might lead us on a wild+    -- goose chase...)+    -- Also keep track of the types we've proved so far in this branch+    -- (if we get back to one we've been to before, we're just in a cycle and+    -- that's no use)+    psRec :: Bool -> Int -> [Name] -> S.Set Type -> ElabD ()+    psRec _ 0 locs tys | fromProver = cantSolveGoal+    psRec rec 0 locs tys = do attack; defer [] nroot; solve --fail "Maximum depth reached"+    psRec False d locs tys = tryCons d locs tys hints +    psRec True d locs tys+                 = do compute+                      ty <- goal+                      when (S.member ty tys) $ fail "Been here before"+                      let tys' = S.insert ty tys                       try' (trivial elab ist)-                           (try' (try' (resolveByCon (d - 1)) (resolveByLocals (d - 1))+                           (try' (try' (resolveByCon (d - 1) locs tys') +                                       (resolveByLocals (d - 1) locs tys')                                  True)              -- if all else fails, make a new metavariable                          (if fromProver @@ -145,42 +190,54 @@     getFn d (Just f) | d < maxDepth-1 = [f]                      | otherwise = [] -    resolveByCon d+    resolveByCon d locs tys         = do t <- goal              let (f, _) = unApply t              case f of-                P _ n _ -> case lookupCtxt n (idris_datatypes ist) of-                               [t] -> tryCons d (hints ++ con_names t ++-                                                                getFn d fn)-                               _ -> fail "Not a data type"+                P _ n _ -> +                   do let autohints = case lookupCtxtExact n (idris_autohints ist) of+                                           Nothing -> []+                                           Just hs -> hs+                      case lookupCtxtExact n (idris_datatypes ist) of+                          Just t -> tryCons d locs tys +                                                   (hints ++ +                                                    con_names t ++ +                                                    autohints ++ +                                                    getFn d fn)+                          Nothing -> fail "Not a data type"                 _ -> fail "Not a data type"      -- if there are local variables which have a function type, try     -- applying them too-    resolveByLocals d+    resolveByLocals d locs tys         = do env <- get_env-             tryLocals d env+             tryLocals d locs tys env -    tryLocals d [] = fail "Locals failed"-    tryLocals d ((x, t) : xs) = try' (tryLocal d x t) (tryLocals d xs) True+    tryLocals d locs tys [] = fail "Locals failed"+    tryLocals d locs tys ((x, t) : xs) +       | x `elem` locs = tryLocals d locs tys xs+       | otherwise = try' (tryLocal d (x : locs) tys x t) +                          (tryLocals d locs tys xs) True -    tryCons d [] = fail "Constructors failed"-    tryCons d (c : cs) = try' (tryCon d c) (tryCons d cs) True+    tryCons d locs tys [] = fail "Constructors failed"+    tryCons d locs tys (c : cs) +        = try' (tryCon d locs tys c) (tryCons d locs tys cs) True -    tryLocal d n t = do let a = getPArity (delab ist (binderTy t))-                        tryLocalArg d n a+    tryLocal d locs tys n t +          = do let a = getPArity (delab ist (binderTy t))+               tryLocalArg d locs tys n a -    tryLocalArg d n 0 = elab (PRef (fileFC "prf") n)-    tryLocalArg d n i = simple_app False (tryLocalArg d n (i - 1))-                                   (psRec True d) "proof search local apply"+    tryLocalArg d locs tys n 0 = elab (PRef (fileFC "prf") n)+    tryLocalArg d locs tys n i +        = simple_app False (tryLocalArg d locs tys n (i - 1))+                (psRec True d locs tys) "proof search local apply"      -- Like type class resolution, but searching with constructors-    tryCon d n = +    tryCon d locs tys n =           do ty <- goal-            let imps = case lookupCtxtName n (idris_implicits ist) of-                            [] -> []-                            [args] -> map isImp (snd args)-                            _ -> fail "Ambiguous name"+            let imps = case lookupCtxtExact n (idris_implicits ist) of+                            Nothing -> []+                            Just args -> map isImp args             ps <- get_probs             hs <- get_holes             args <- map snd <$> try' (apply (Var n) imps)@@ -190,7 +247,7 @@             when (length ps < length ps') $ fail "Can't apply constructor"             mapM_ (\ (_, h) -> do focus h                                   aty <- goal-                                  psRec True d) +                                  psRec True d locs tys)                   (filter (\ (x, y) -> not x) (zip (map fst imps) args))             solve
src/Idris/Prover.hs view
@@ -9,13 +9,13 @@  import Idris.Elab.Utils import Idris.Elab.Value+import Idris.Elab.Term  import Idris.AbsSyntax import Idris.AbsSyntaxTree import Idris.Delaborate import Idris.Docs (getDocs, pprintDocs, pprintConstDocs) import Idris.ElabDecls-import Idris.ElabTerm import Idris.Parser hiding (params) import Idris.Error import Idris.DataOpts@@ -66,7 +66,7 @@  prove :: Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris () prove opt ctxt lit n ty-    = do let ps = initElaborator n ctxt ty+    = do ps <- fmap (\ist -> initElaborator n ctxt (idris_datatypes ist) ty) getIState          idemodePutSExp "start-proof-mode" n          (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, initEState) "" Nothing) Nothing          iLOG $ "Adding " ++ show tm@@ -297,7 +297,7 @@                   infixes = idris_infixes ist                   action = case tm of                     TType _ ->-                      iPrintTermWithType (prettyImp ppo PType) type1Doc+                      iPrintTermWithType (prettyImp ppo (PType emptyFC)) type1Doc                     _ -> let bnd = map (\x -> (fst x, False)) env in                          iPrintTermWithType (pprintPTerm ppo bnd [] infixes (delab ist tm))                                              (pprintPTerm ppo bnd [] infixes (delab ist ty))
src/Idris/REPL.hs view
@@ -8,7 +8,6 @@ import Idris.Apropos (apropos, aproposModules) import Idris.REPLParser import Idris.ElabDecls-import Idris.ElabTerm import Idris.Erasure import Idris.Error import Idris.ErrReverse@@ -35,10 +34,13 @@ import Idris.TypeSearch (searchByType) import Idris.IBC (loadPkgIndex, writePkgIndex) +import Idris.REPL.Browse (namesInNS, namespacesInNS)+ import Idris.Elab.Type import Idris.Elab.Clause import Idris.Elab.Data import Idris.Elab.Value+import Idris.Elab.Term  import Version_idris (gitHash) import Util.System@@ -59,7 +61,7 @@  import Control.Category import qualified Control.Exception as X-import Prelude hiding ((.), id)+import Prelude hiding ((<$>), (.), id) import Data.List.Split (splitOn) import Data.List (groupBy) import qualified Data.Text as T@@ -436,7 +438,7 @@           in             displaySpans .             renderPretty 0.9 cols .-            fmap (fancifyAnnots ist) .+            fmap (fancifyAnnots ist True) .             annotate (AnnTerm (zip bnd (take (length bnd) (repeat False))) t) $               prettyT @@ -461,8 +463,9 @@                      runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id   where pn ist = displaySpans .                  renderPretty 0.9 1000 .-                 fmap (fancifyAnnots ist) .+                 fmap (fancifyAnnots ist True) .                  prettyName True True []+ runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) =   case splitName n of        Left err -> iPrintError err@@ -473,9 +476,23 @@                      runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id   where pn ist = displaySpans .                  renderPretty 0.9 1000 .-                 fmap (fancifyAnnots ist) .+                 fmap (fancifyAnnots ist True) .                  prettyName True True [] +runIdeModeCommand h id orig fn modes (IdeMode.BrowseNS ns) =+  case splitOn "." ns of+    [] -> iPrintError "No namespace provided"+    ns -> do underNSs <- fmap (map $ concat . intersperse ".") $ namespacesInNS ns+             names <- namesInNS ns+             if null underNSs && null names+                then iPrintError "Invalid or empty namespace"+                else do ist <- getIState+                        let msg = (IdeMode.SymbolAtom "ok", (underNSs, map (pn ist) names))+                        runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id+  where pn ist = displaySpans .+                 renderPretty 0.9 1000 .+                 fmap (fancifyAnnots ist True) .+                 prettyName True True [] runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) =   do ctxt <- getContext      ist <- getIState@@ -489,7 +506,7 @@          msg = (IdeMode.SymbolAtom "ok",                 displaySpans .                 renderPretty 0.9 80 .-                fmap (fancifyAnnots ist) $ ptm)+                fmap (fancifyAnnots ist True) $ ptm)      runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id runIdeModeCommand h id orig fn modes (IdeMode.TermShowImplicits bnd tm) =   ideModeForceTermImplicits h id bnd True tm@@ -502,7 +519,7 @@          msg = (IdeMode.SymbolAtom "ok",                 displaySpans .                 renderPretty 0.9 70 .-                fmap (fancifyAnnots ist) $ ptm)+                fmap (fancifyAnnots ist True) $ ptm)      runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id runIdeModeCommand h id orig fn mods (IdeMode.PrintDef name) =   case splitName name of@@ -518,7 +535,7 @@      let (out, spans) =            displaySpans .            renderPretty 0.9 80 .-           fmap (fancifyAnnots ist) $ pprintErr ist e+           fmap (fancifyAnnots ist True) $ pprintErr ist e          msg = (IdeMode.SymbolAtom "ok", out, spans)      runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id runIdeModeCommand h id orig fn modes IdeMode.GetIdrisVersion =@@ -541,7 +558,7 @@          msg = (IdeMode.SymbolAtom "ok",                 displaySpans .                 renderPretty 0.9 80 .-                fmap (fancifyAnnots ist) $ expl)+                fmap (fancifyAnnots ist True) $ expl)      runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id  splitName :: String -> Either String Name@@ -582,8 +599,8 @@ --idemodeProcess fn TTShell = process fn TTShell -- need some prove mode! idemodeProcess fn (TestInline t) = process fn (TestInline t) -idemodeProcess fn Execute = do process fn Execute-                               iPrintResult ""+idemodeProcess fn (Execute t) = do process fn (Execute t)+                                   iPrintResult "" idemodeProcess fn (Compile codegen f) = do process fn (Compile codegen f)                                            iPrintResult "" idemodeProcess fn (LogLvl i) = do process fn (LogLvl i)@@ -771,16 +788,16 @@         mapM_ defineName namedGroups where   namedGroups = groupBy (\d1 d2 -> getName d1 == getName d2) decls   getName :: PDecl -> Maybe Name-  getName (PTy docs argdocs syn fc opts name ty) = Just name+  getName (PTy docs argdocs syn fc opts name _ ty) = Just name   getName (PClauses fc opts name (clause:clauses)) = Just (getClauseName clause)   getName (PData doc argdocs syn fc opts dataDecl) = Just (d_name dataDecl)-  getName (PClass doc syn fc constraints name parms parmdocs fds decls) = Just name+  getName (PClass doc syn fc constraints name nfc parms parmdocs fds decls _ _) = Just name   getName _ = Nothing   -- getClauseName is partial and I am not sure it's used safely! -- trillioneyes   getClauseName (PClause fc name whole with rhs whereBlock) = name   getClauseName (PWith fc name whole with rhs pn whereBlock) = name   defineName :: [PDecl] -> Idris ()-  defineName (tyDecl@(PTy docs argdocs syn fc opts name ty) : decls) = do+  defineName (tyDecl@(PTy docs argdocs syn fc opts name _ ty) : decls) = do     elabDecl EAll recinfo tyDecl     elabClauses recinfo fc opts name (concatMap getClauses decls)     setReplDefined (Just name)@@ -822,8 +839,8 @@   fixClauses :: PDecl' t -> PDecl' t   fixClauses (PClauses fc opts _ css@(clause:cs)) =     PClauses fc opts (getClauseName clause) css-  fixClauses (PInstance doc argDocs syn fc constraints cls parms ty instName decls) =-    PInstance doc argDocs syn fc constraints cls parms ty instName (map fixClauses decls)+  fixClauses (PInstance doc argDocs syn fc constraints cls nfc parms ty instName decls) =+    PInstance doc argDocs syn fc constraints cls nfc parms ty instName (map fixClauses decls)   fixClauses decl = decl  process fn (Undefine names) = undefine names@@ -879,7 +896,7 @@         case lookupNames n ctxt of           ts@(t:_) ->             case lookup t (idris_metavars ist) of-                Just (_, i, _) -> iRenderResult . fmap (fancifyAnnots ist) $+                Just (_, i, _) -> iRenderResult . fmap (fancifyAnnots ist True) $                                   showMetavarInfo ppo ist n i                 Nothing -> iPrintFunTypes [] n (map (\n -> (n, pprintDelabTy ist n)) ts)           [] -> iPrintError $ "No such variable " ++ show n@@ -889,7 +906,7 @@                 (ty:_) -> putTy ppo ist i [] (delab ist (errReverse ist ty))     putTy :: PPOption -> IState -> Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation     putTy ppo ist 0 bnd sc = putGoal ppo ist bnd sc-    putTy ppo ist i bnd (PPi _ n t sc)+    putTy ppo ist i bnd (PPi _ n _ t sc)                = let current = text "  " <>                                (case n of                                    MN _ _ -> text "_"@@ -915,7 +932,7 @@             ty' = normaliseC ctxt [] ty         case tm of            TType _ ->-             iPrintTermWithType (prettyIst ist PType) type1Doc+             iPrintTermWithType (prettyIst ist (PType emptyFC)) type1Doc            _ -> iPrintTermWithType (pprintDelab ist tm)                                    (pprintDelab ist ty) @@ -1059,7 +1076,7 @@                     else ifail $ "Neither \""++fn''++"\" nor \""++fnExt++"\" exist"        let fb = fn ++ "~"        runIO $ copyFile fn fb -- make a backup in case something goes wrong!-       prog <- runIO $ readFile fb+       prog <- runIO $ readSource fb        i <- getIState        let proofs = proof_list i        n' <- case prf of@@ -1071,7 +1088,7 @@        case lookup n proofs of             Nothing -> iputStrLn "No proof to add"             Just p  -> do let prog' = insertScript (showProof (lit fn) n p) ls-                          runIO $ writeFile fn (unlines prog')+                          runIO $ writeSource fn (unlines prog')                           removeProof n                           iputStrLn $ "Added proof " ++ show n                           where ls = (lines prog)@@ -1115,13 +1132,10 @@                                 let tm' = inlineTerm ist tm                                 c <- colourise                                 iPrintResult (showTm ist (delab ist tm'))-process fn Execute+process fn (Execute tm)                    = idrisCatch                        (do ist <- getIState-                           (m, _) <- elabVal recinfo ERHS-                                           (PApp fc-                                              (PRef fc (sUN "run__IO"))-                                              [pexp $ PRef fc (sNS (sUN "main") ["Main"])])+                           (m, _) <- elabVal recinfo ERHS (elabExec fc tm)                            (tmpn, tmph) <- runIO tempfile                            runIO $ hClose tmph                            t <- codegen@@ -1232,10 +1246,11 @@                           delabTy ist n,                           fmap (overview . fst) (lookupCtxtExact n (idris_docstrings ist)))                        | n <- sort names, isUN n ]-     iRenderResult $ vsep (map (\(m, d) -> text "Module" <+> text m <$>-                                           ppD ist d <> line) mods) <$>-                     vsep (map (prettyDocumentedIst ist) aproposInfo)-     putIState orig+     if (not (null mods)) || (not (null aproposInfo))+        then iRenderResult $ vsep (map (\(m, d) -> text "Module" <+> text m <$>+                                                   ppD ist d <> line) mods) <$>+                             vsep (map (prettyDocumentedIst ist) aproposInfo)+        else iRenderError $ text "No results found"   where isUN (UN _) = True         isUN (NS n _) = isUN n         isUN _ = False@@ -1259,11 +1274,26 @@              prettyName True True [] n <+> text "calls:" <$>              indent 1 (vsep (map ((text "*" <+>) . align . prettyName True True []) ns)))            calls++process fn (Browse ns) =+  do underNSs <- namespacesInNS ns+     names <- namesInNS ns+     if null underNSs && null names+        then iPrintError "Invalid or empty namespace"+        else do ist <- getIState+                iRenderResult $+                  text "Namespaces:" <$>+                  indent 2 (vsep (map (text . showSep ".") underNSs)) <$>+                  text "Names:" <$>+                  indent 2 (vsep (map (\n -> prettyName True False [] n <+> colon <+>+                                             (group . align $ pprintDelabTy ist n))+                                      names))+ -- IdrisDoc process fn (MakeDoc s) =   do     istate        <- getIState          let names      = words s-             parse n    | Success x <- runparser name istate fn n = Right x+             parse n    | Success x <- runparser (fmap fst name) istate fn n = Right x              parse n    = Left n              (bad, nss) = partitionEithers $ map parse names          cd            <- runIO $ getCurrentDirectory@@ -1557,7 +1587,7 @@         when (DefaultTotal `elem` opts) $ do i <- getIState                                             putIState (i { default_total = True })-       setColourise $ not quiet && last (True : opt getColour opts)+       setColourise $ not quiet && last ((not isWindows) : opt getColour opts)
+ src/Idris/REPL/Browse.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-unused-imports #-}++module Idris.REPL.Browse (namespacesInNS, namesInNS) where++import Control.Monad (filterM)++import Data.List (isSuffixOf, nub)+import Data.Maybe (mapMaybe)+import qualified Data.Text as T (unpack)++import Idris.Core.Evaluate (ctxtAlist, Accessibility(Hidden), lookupDefAccExact)+import Idris.Core.TT (Name(..))++import Idris.AbsSyntaxTree (Idris)+import Idris.AbsSyntax (getContext)++-- | Find the sub-namespaces of a given namespace. The components+-- should be in display order rather than the order that they are in+-- inside of NS constructors.+namespacesInNS :: [String] -> Idris [[String]]+namespacesInNS ns = do let revNS = reverse ns+                       allNames <- fmap ctxtAlist getContext+                       return . nub $+                         [ reverse space | space <- mapMaybe (getNS . fst) allNames+                                         , revNS `isSuffixOf` space+                                         , revNS /= space ]+  where getNS (NS _ namespace) = Just (map T.unpack namespace)+        getNS _ = Nothing++-- | Find the user-accessible names that occur directly within a given+-- namespace. The components should be in display order rather than+-- the order that they are in inside of NS constructors.+namesInNS :: [String] -> Idris [Name]+namesInNS ns = do let revNS = reverse ns+                  allNames <- fmap ctxtAlist getContext+                  let namesInSpace = [ n | (n, space) <- mapMaybe (getNS . fst) allNames+                                         , revNS == space ]+                  filterM accessible namesInSpace+  where getNS n@(NS (UN n') namespace) = Just (n, (map T.unpack namespace))+        getNS _ = Nothing+        accessible n = do ctxt <- getContext+                          case lookupDefAccExact n False ctxt of+                            Just (_, Hidden ) -> return False+                            _ -> return True
src/Idris/REPLParser.hs view
@@ -52,6 +52,7 @@     , " Search for values by type", cmd_search)   , nameArgCmd ["wc", "whocalls"] WhoCalls "List the callers of some name"   , nameArgCmd ["cw", "callswho"] CallsWho "List the callees of some name"+  , namespaceArgCmd ["browse"] Browse "List the contents of some namespace"   , nameArgCmd ["total"] TotCheck "Check the totality of a name"   , noArgCmd ["r", "reload"] Reload "Reload current file"   , (["l", "load"], FileArg, "Load a new file"@@ -71,7 +72,7 @@   , noArgCmd ["proofs"] Proofs "Show available proofs"   , exprArgCmd ["x"] ExecVal "Execute IO actions resulting from an expression using the interpreter"   , (["c", "compile"], FileArg, "Compile to an executable [codegen] <filename>", cmd_compile)-  , noArgCmd ["exec", "execute"] Execute "Compile to an executable and run"+  , (["exec", "execute"], OptionalArg ExprArg, "Compile to an executable and run", cmd_execute)   , (["dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)", cmd_dynamic)   , (["dynamic"], NoArg, "List dynamically loaded C libraries", cmd_dynamic)   , noArgCmd ["?", "h", "help"] Help "Display this help text"@@ -136,17 +137,19 @@     )   ] -noArgCmd names command doc = +noArgCmd names command doc =   (names, NoArg, doc, noArgs command)-nameArgCmd names command doc = +nameArgCmd names command doc =   (names, NameArg, doc, fnNameArg command)-exprArgCmd names command doc = +namespaceArgCmd names command doc =+  (names, NamespaceArg, doc, namespaceArg command)+exprArgCmd names command doc =   (names, ExprArg, doc, exprArg command)-metavarArgCmd names command doc = +metavarArgCmd names command doc =   (names, MetaVarArg, doc, fnNameArg command)-optArgCmd names command doc = +optArgCmd names command doc =   (names, OptionArg, doc, optArg command)-proofArgCmd names command doc = +proofArgCmd names command doc =   (names, NoArg, doc, proofArg command)  pCmd :: P.IdrisParser (Either String Command)@@ -209,17 +212,22 @@     failure = return $ Left ("Usage is :" ++ name ++ " <" ++ argName ++ ">")  nameArg, fnNameArg :: (Name -> Command) -> String -> P.IdrisParser (Either String Command)-nameArg = genArg "name" P.name-fnNameArg = genArg "functionname" P.fnName+nameArg = genArg "name" $ fst <$> P.name+fnNameArg = genArg "functionname" $ fst <$> P.fnName  strArg :: (String -> Command) -> String -> P.IdrisParser (Either String Command) strArg = genArg "string" (many anyChar)  moduleArg :: (FilePath -> Command) -> String -> P.IdrisParser (Either String Command)-moduleArg = genArg "module" (fmap toPath P.identifier) +moduleArg = genArg "module" (fmap (toPath . fst) P.identifier)    where     toPath n = foldl1' (</>) $ splitOn "." n +namespaceArg :: ([String] -> Command) -> String -> P.IdrisParser (Either String Command)+namespaceArg = genArg "namespace" (fmap (toNS . fst) P.identifier) +  where+    toNS  = splitOn "."+ optArg :: (Opt -> Command) -> String -> P.IdrisParser (Either String Command) optArg cmd name = do     let emptyArgs = do@@ -250,14 +258,14 @@     upd <- option False $ do         P.lchar '!'         return True-    l <- P.natural-    n <- P.name;+    l <- fst <$> P.natural+    n <- fst <$> P.name;     return (Right (cmd upd (fromInteger l) n))  cmd_doc :: String -> P.IdrisParser (Either String Command) cmd_doc name = do     let constant = do-        c <- P.constant+        c <- fmap fst P.constant         eof         return $ Right (DocStr (Right c) FullDocs) @@ -274,8 +282,17 @@         pConsoleWidth :: P.IdrisParser ConsoleWidth         pConsoleWidth = do discard (P.symbol "auto"); return AutomaticWidth                     <|> do discard (P.symbol "infinite"); return InfinitelyWide-                    <|> do n <- fmap fromInteger P.natural; return (ColsWide n)+                    <|> do n <- fmap (fromInteger . fst) P.natural+                           return (ColsWide n) +cmd_execute :: String -> P.IdrisParser (Either String Command)+cmd_execute name = do+    tm <- option maintm (P.fullExpr defaultSyntax)+    return (Right (Execute tm))+  where+    maintm = PRef (fileFC "(repl)") (sNS (sUN "main") ["Main"])++ cmd_dynamic :: String -> P.IdrisParser (Either String Command) cmd_dynamic name = do     let emptyArgs = noArgs ListDynamic name@@ -291,7 +308,7 @@ cmd_pprint name = do      fmt <- ppFormat      P.whiteSpace-     n <- fmap fromInteger P.natural+     n <- fmap (fromInteger . fst) P.natural      P.whiteSpace      t <- P.fullExpr defaultSyntax      return (Right (PPrint fmt n t))@@ -310,20 +327,20 @@     let codegenOption :: P.IdrisParser Codegen         codegenOption = do             let bytecodeCodegen = discard (P.symbol "bytecode") *> return Bytecode-                viaCodegen = do x <- P.identifier+                viaCodegen = do x <- fst <$> P.identifier                                 return (Via (map toLower x))             bytecodeCodegen <|> viaCodegen      let hasOneArg = do         i <- get-        f <- P.identifier+        f <- fst <$> P.identifier         eof         return $ Right (Compile defaultCodegen f)      let hasTwoArgs = do         i <- get         codegen <- codegenOption-        f <- P.identifier+        f <- fst <$> P.identifier         eof         return $ Right (Compile codegen f) @@ -333,16 +350,16 @@ cmd_addproof :: String -> P.IdrisParser (Either String Command) cmd_addproof name = do     n <- option Nothing $ do-        x <- P.name;+        x <- fst <$> P.name         return (Just x)     eof     return (Right (AddProof n))  cmd_log :: String -> P.IdrisParser (Either String Command) cmd_log name = do-    i <- P.natural+    i <- fmap (fromIntegral . fst) P.natural     eof-    return (Right (LogLvl (fromIntegral i)))+    return (Right (LogLvl i))  cmd_let :: String -> P.IdrisParser (Either String Command) cmd_let name = do@@ -350,13 +367,13 @@     return (Right (NewDefn defn))  cmd_unlet :: String -> P.IdrisParser (Either String Command)-cmd_unlet name = (Right . Undefine) `fmap` many P.name+cmd_unlet name = (Right . Undefine) `fmap` many (fst <$> P.name)  cmd_loadto :: String -> P.IdrisParser (Either String Command) cmd_loadto name = do-    toline <- P.natural+    toline <- fmap (fromInteger . fst) P.natural     f <- many anyChar;-    return (Right (Load f (Just (fromInteger toline))))+    return (Right (Load f (Just toline)))  cmd_colour :: String -> P.IdrisParser (Either String Command) cmd_colour name = fmap Right pSetColourCmd@@ -436,19 +453,19 @@   return (Right (cmd pkgs val))  cmd_search :: String -> P.IdrisParser (Either String Command)-cmd_search = packageBasedCmd +cmd_search = packageBasedCmd   (P.typeExpr (defaultSyntax { implicitAllowed = True })) Search  cmd_proofsearch :: String -> P.IdrisParser (Either String Command) cmd_proofsearch name = do     upd <- option False (do P.lchar '!'; return True)-    l <- P.natural; n <- P.name;-    hints <- many P.fnName-    return (Right (DoProofSearch upd True (fromInteger l) n hints))+    l <- fmap (fromInteger . fst) P.natural; n <- fst <$> P.name+    hints <- many (fst <$> P.fnName)+    return (Right (DoProofSearch upd True l n hints))  cmd_refine :: String -> P.IdrisParser (Either String Command) cmd_refine name = do    upd <- option False (do P.lchar '!'; return True)-   l <- P.natural; n <- P.name;-   hint <- P.fnName-   return (Right (DoProofSearch upd False (fromInteger l) n [hint]))+   l <- fmap (fromInteger . fst) P.natural; n <- fst <$> P.name+   hint <- fst <$> P.fnName+   return (Right (DoProofSearch upd False l n [hint]))
src/Idris/Reflection.hs view
@@ -1,18 +1,1003 @@-{-|-Handy tools for doing reflection.+{-| Code related to Idris's reflection system. This module contains+quoters and unquoters along with some supporting datatypes. -}+{-# LANGUAGE PatternGuards #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-unused-imports #-} module Idris.Reflection where +import Control.Applicative ((<$>), (<*>), pure)+import Control.Monad (liftM, liftM2)+import Data.Maybe (catMaybes)+import Data.List ((\\))+import qualified Data.Text as T++import Idris.Core.Elaborate (claim, fill, focus, getNameFrom, initElaborator,+                             movelast, runElab, solve)+import Idris.Core.Evaluate (Context, Def(TyDecl), initContext, lookupDefExact, lookupTyExact) import Idris.Core.TT-import Idris.AbsSyntaxTree (PArg'(..), PArg, PTerm(Placeholder)) -data RArg = RExplicit { argName :: Name, argTy :: Raw }-          | RImplicit { argName :: Name, argTy :: Raw }+import Idris.AbsSyntaxTree (ElabD, IState, PArg'(..), PArg, PTactic, PTactic'(..),+                            PTerm(..), initEState, pairCon, pairTy)+import Idris.Delaborate (delab)++data RArg = RExplicit   { argName :: Name, argTy :: Raw }+          | RImplicit   { argName :: Name, argTy :: Raw }           | RConstraint { argName :: Name, argTy :: Raw }+  deriving Show -data RTyDecl = RDeclare Name [RArg] Raw+data RTyDecl = RDeclare Name [RArg] Raw deriving Show +data RTyConArg = RParameter { tcArgName :: Name, tcArgTy :: Raw }+               | RIndex     { tcArgName :: Name, tcArgTy :: Raw }+  deriving Show++data RDatatype = RDatatype Name [RTyConArg] Raw [(Name, Raw)] deriving Show+ rArgToPArg :: RArg -> PArg rArgToPArg (RExplicit n _) = PExp 0 [] n Placeholder rArgToPArg (RImplicit n _) = PImp 0 False [] n Placeholder rArgToPArg (RConstraint n _) = PConstraint 0 [] n Placeholder++data RFunClause = RMkFunClause Raw Raw+                | RMkImpossibleClause Raw+                deriving Show++data RFunDefn = RDefineFun Name [RFunClause] deriving Show++-- | Prefix a name with the "Language.Reflection" namespace+reflm :: String -> Name+reflm n = sNS (sUN n) ["Reflection", "Language"]++-- | Prefix a name with the "Language.Reflection.Elab" namespace+tacN :: String -> Name+tacN str = sNS (sUN str) ["Elab", "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 _ (P _ n _) | n == reflm "Skip" = return Skip+reify _ (P _ n _) | n == reflm "SourceFC" = return SourceFC+reify _ (P _ n _) | n == reflm "Unfocus" = return Unfocus+reify ist t@(App _ _ _)+          | (P _ f _, args) <- unApply t = reifyApp ist f args+reify _ t = fail ("Unknown tactic " ++ show t)++reifyApp :: IState -> Name -> [Term] -> ElabD PTactic+reifyApp ist t [l, r] | t == reflm "Try" = liftM2 Try (reify ist l) (reify ist r)+reifyApp _ t [Constant (I i)]+           | t == reflm "Search" = return (ProofSearch True True i Nothing [])+reifyApp _ t [x]+           | t == reflm "Refine" = do n <- reifyTTName x+                                      return $ Refine n []+reifyApp ist t [n, ty] | t == reflm "Claim" = do n' <- reifyTTName n+                                                 goal <- reifyTT ty+                                                 return $ Claim n' (delab ist goal)+reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist r)+reifyApp ist t [Constant (Str n), x]+             | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)+reifyApp _ t [n] | t == reflm "Intro" = liftM (Intro . (:[])) (reifyTTName n)+reifyApp ist t [t'] | t == reflm "Induction" = liftM (Induction . delab ist) (reifyTT t')+reifyApp ist t [t'] | t == reflm "Case" = liftM (Induction . delab ist) (reifyTT t')+reifyApp ist t [t']+             | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')+reifyApp ist t [t']+             | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')+reifyApp ist t [t']+             | t == reflm "ByReflection" = liftM (ByReflection . delab ist) (reifyTT t')+reifyApp _ t [t']+           | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t')+reifyApp ist t [t']+             | t == reflm "Exact" = liftM (Exact . delab ist) (reifyTT t')+reifyApp ist t [x]+             | t == reflm "Focus" = liftM Focus (reifyTTName x)+reifyApp ist t [t']+             | t == reflm "Rewrite" = liftM (Rewrite . delab ist) (reifyTT t')+reifyApp ist t [n, t']+             | t == reflm "LetTac" = do n'  <- reifyTTName n+                                        t'' <- reifyTT t'+                                        return $ LetTac n' (delab ist t')+reifyApp ist t [n, tt', t']+             | t == reflm "LetTacTy" = do n'   <- reifyTTName n+                                          tt'' <- reifyTT tt'+                                          t''  <- reifyTT t'+                                          return $ LetTacTy n' (delab ist tt'') (delab ist t'')+reifyApp ist t [errs]+             | t == reflm "Fail" = fmap TFail (reifyReportParts errs)+reifyApp _ f args = fail ("Unknown tactic " ++ show (f, args)) -- shouldn't happen++reifyReportParts :: Term -> ElabD [ErrorReportPart]+reifyReportParts errs =+  case unList errs of+    Nothing -> fail "Failed to reify errors"+    Just errs' ->+      let parts = mapM reifyReportPart errs' in+      case parts of+        Left err -> fail $ "Couldn't reify \"Fail\" tactic - " ++ show err+        Right errs'' ->+          return errs''++-- | Reify terms from their reflected representation+reifyTT :: Term -> ElabD Term+reifyTT t@(App _ _ _)+        | (P _ f _, args) <- unApply t = reifyTTApp f args+reifyTT t@(P _ n _)+        | n == reflm "Erased" = return $ Erased+reifyTT t@(P _ n _)+        | n == reflm "Impossible" = return $ Impossible+reifyTT t = fail ("Unknown reflection term: " ++ show t)++reifyTTApp :: Name -> [Term] -> ElabD Term+reifyTTApp t [nt, n, x]+           | t == reflm "P" = do nt' <- reifyTTNameType nt+                                 n'  <- reifyTTName n+                                 x'  <- reifyTT x+                                 return $ P nt' n' x'+reifyTTApp t [Constant (I i)]+           | t == reflm "V" = return $ V i+reifyTTApp t [n, b, x]+           | t == reflm "Bind" = do n' <- reifyTTName n+                                    b' <- reifyTTBinder reifyTT (reflm "TT") b+                                    x' <- reifyTT x+                                    return $ Bind n' b' x'+reifyTTApp t [f, x]+           | t == reflm "App" = do f' <- reifyTT f+                                   x' <- reifyTT x+                                   return $ App Complete f' x'+reifyTTApp t [c]+           | t == reflm "TConst" = liftM Constant (reifyTTConst c)+reifyTTApp t [t', Constant (I i)]+           | t == reflm "Proj" = do t'' <- reifyTT t'+                                    return $ Proj t'' i+reifyTTApp t [tt]+           | t == reflm "TType" = liftM TType (reifyTTUExp tt)+reifyTTApp t args = fail ("Unknown reflection term: " ++ show (t, args))++-- | Reify raw terms from their reflected representation+reifyRaw :: Term -> ElabD Raw+reifyRaw t@(App _ _ _)+         | (P _ f _, args) <- unApply t = reifyRawApp f args+reifyRaw t@(P _ n _)+         | n == reflm "RType" = return $ RType+reifyRaw t = fail ("Unknown reflection raw term in reifyRaw: " ++ show t)++reifyRawApp :: Name -> [Term] -> ElabD Raw+reifyRawApp t [n]+            | t == reflm "Var" = liftM Var (reifyTTName n)+reifyRawApp t [n, b, x]+            | t == reflm "RBind" = do n' <- reifyTTName n+                                      b' <- reifyTTBinder reifyRaw (reflm "Raw") b+                                      x' <- reifyRaw x+                                      return $ RBind n' b' x'+reifyRawApp t [f, x]+            | t == reflm "RApp" = liftM2 RApp (reifyRaw f) (reifyRaw x)+reifyRawApp t [t']+            | t == reflm "RForce" = liftM RForce (reifyRaw t')+reifyRawApp t [c]+            | t == reflm "RConstant" = liftM RConstant (reifyTTConst c)+reifyRawApp t args = fail ("Unknown reflection raw term in reifyRawApp: " ++ show (t, args))++reifyTTName :: Term -> ElabD Name+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 $ sUN n+reifyTTNameApp t [n, ns]+               | t == reflm "NS" = do n'  <- reifyTTName n+                                      ns' <- reifyTTNamespace ns+                                      return $ sNS n' ns'+reifyTTNameApp t [Constant (I i), Constant (Str n)]+               | t == reflm "MN" = return $ sMN i n+reifyTTNameApp t [sn]+               | t == reflm "SN"+               , (P _ f _, args) <- unApply sn = SN <$> reifySN f args+  where reifySN :: Name -> [Term] -> ElabD SpecialName+        reifySN t [Constant (I i), n1, n2]+                | t == reflm "WhereN" = WhereN i <$> reifyTTName n1 <*> reifyTTName n2+        reifySN t [Constant (I i), n]+                | t == reflm "WithN" = WithN i <$> reifyTTName n+        reifySN t [n, ss]+                | t == reflm "InstanceN" =+                  case unList ss of+                    Nothing -> fail "Can't reify InstanceN strings"+                    Just ss' -> InstanceN <$> reifyTTName n <*>+                                 pure [T.pack s | Constant (Str s) <- ss']+        reifySN t [n, Constant (Str s)]+                | t == reflm "ParentN" =+                  ParentN <$> reifyTTName n <*> pure (T.pack s)+        reifySN t [n]+                | t == reflm "MethodN" =+                  MethodN <$> reifyTTName n+        reifySN t [n]+                | t == reflm "CaseN" =+                  CaseN <$> reifyTTName n+        reifySN t [n]+                | t == reflm "ElimN" =+                  ElimN <$> reifyTTName n+        reifySN t [n]+                | t == reflm "InstanceCtorN" =+                  InstanceCtorN <$> reifyTTName n+        reifySN t [n1, n2]+                | t == reflm "MetaN" =+                  MetaN <$> reifyTTName n1 <*> reifyTTName n2+        reifySN t args = fail $ "Can't reify special name " ++ show t ++ show args+reifyTTNameApp t []+               | t == reflm "NErased" = return NErased+reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))++reifyTTNamespace :: Term -> ElabD [String]+reifyTTNamespace t@(App _ _ _)+  = case unApply t of+      (P _ f _, [Constant StrType])+           | f == sNS (sUN "Nil") ["List", "Prelude"] -> return []+      (P _ f _, [Constant StrType, Constant (Str n), 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)++reifyTTNameType :: Term -> ElabD NameType+reifyTTNameType t@(P _ n _) | n == reflm "Bound" = return $ Bound+reifyTTNameType t@(P _ n _) | n == reflm "Ref" = return $ Ref+reifyTTNameType t@(App _ _ _)+  = case unApply t of+      (P _ f _, [Constant (I tag), Constant (I num)])+           | f == reflm "DCon" -> return $ DCon tag num False -- FIXME: Uniqueness!+           | f == reflm "TCon" -> return $ TCon tag num+      _ -> fail ("Unknown reflection name type: " ++ show t)+reifyTTNameType t = fail ("Unknown reflection name type: " ++ show t)++reifyTTBinder :: (Term -> ElabD a) -> Name -> Term -> ElabD (Binder a)+reifyTTBinder reificator binderType t@(App _ _ _)+  = case unApply t of+     (P _ f _, bt:args) | forget bt == Var binderType+       -> reifyTTBinderApp reificator f args+     _ -> fail ("Mismatching binder reflection: " ++ show t)+reifyTTBinder _ _ t = fail ("Unknown reflection binder: " ++ show t)++reifyTTBinderApp :: (Term -> ElabD a) -> Name -> [Term] -> ElabD (Binder a)+reifyTTBinderApp reif f [t]+                      | f == reflm "Lam" = liftM Lam (reif t)+reifyTTBinderApp reif f [t, k]+                      | f == reflm "Pi" = liftM2 (Pi Nothing) (reif t) (reif k)+reifyTTBinderApp reif f [x, y]+                      | f == reflm "Let" = liftM2 Let (reif x) (reif y)+reifyTTBinderApp reif f [x, y]+                      | f == reflm "NLet" = liftM2 NLet (reif x) (reif y)+reifyTTBinderApp reif f [t]+                      | f == reflm "Hole" = liftM Hole (reif t)+reifyTTBinderApp reif f [t]+                      | f == reflm "GHole" = liftM (GHole 0) (reif t)+reifyTTBinderApp reif f [x, y]+                      | f == reflm "Guess" = liftM2 Guess (reif x) (reif y)+reifyTTBinderApp reif f [t]+                      | f == reflm "PVar" = liftM PVar (reif t)+reifyTTBinderApp reif f [t]+                      | f == reflm "PVTy" = liftM PVTy (reif t)+reifyTTBinderApp _ f args = fail ("Unknown reflection binder: " ++ show (f, args))++reifyTTConst :: Term -> ElabD Const+reifyTTConst (P _ n _) | n == reflm "StrType"  = return $ StrType+reifyTTConst (P _ n _) | n == reflm "VoidType" = return $ VoidType+reifyTTConst (P _ n _) | n == reflm "Forgot"   = return $ Forgot+reifyTTConst t@(App _ _ _)+             | (P _ f _, [arg]) <- unApply t   = reifyTTConstApp f arg+reifyTTConst t = fail ("Unknown reflection constant: " ++ show t)++reifyTTConstApp :: Name -> Term -> ElabD Const+reifyTTConstApp f aty+                | f == reflm "AType" = fmap AType (reifyArithTy aty)+reifyTTConstApp f (Constant c@(I _))+                | f == reflm "I"   = return $ c+reifyTTConstApp f (Constant c@(BI _))+                | f == reflm "BI"  = return $ c+reifyTTConstApp f (Constant c@(Fl _))+                | f == reflm "Fl"  = return $ c+reifyTTConstApp f (Constant c@(I _))+                | f == reflm "Ch"  = return $ c+reifyTTConstApp f (Constant c@(Str _))+                | f == reflm "Str" = return $ c+reifyTTConstApp f (Constant c@(B8 _))+                | f == reflm "B8"  = return $ c+reifyTTConstApp f (Constant c@(B16 _))+                | f == reflm "B16" = return $ c+reifyTTConstApp f (Constant c@(B32 _))+                | f == reflm "B32" = return $ c+reifyTTConstApp f (Constant c@(B64 _))+                | f == reflm "B64" = return $ c+reifyTTConstApp f arg = fail ("Unknown reflection constant: " ++ show (f, arg))++reifyArithTy :: Term -> ElabD ArithTy+reifyArithTy (App _ (P _ n _) intTy) | n == reflm "ATInt"   = fmap ATInt (reifyIntTy intTy)+reifyArithTy (P _ n _)             | n == reflm "ATFloat" = return ATFloat+reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)++reifyNativeTy :: Term -> ElabD NativeTy+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8+reifyNativeTy x = fail $ "Couldn't reify reflected NativeTy " ++ show x++reifyIntTy :: Term -> ElabD IntTy+reifyIntTy (App _ (P _ n _) nt) | n == reflm "ITFixed" = fmap ITFixed (reifyNativeTy nt)+reifyIntTy (P _ n _) | n == reflm "ITNative" = return ITNative+reifyIntTy (P _ n _) | n == reflm "ITBig" = return ITBig+reifyIntTy (P _ n _) | n == reflm "ITChar" = return ITChar+reifyIntTy tm = fail $ "The term " ++ show tm ++ " is not a reflected IntTy"++reifyTTUExp :: Term -> ElabD UExp+reifyTTUExp t@(App _ _ _)+  = case unApply t of+      (P _ f _, [Constant (I i)]) | f == reflm "UVar" -> return $ UVar i+      (P _ f _, [Constant (I i)]) | f == reflm "UVal" -> return $ UVal i+      _ -> fail ("Unknown reflection type universe expression: " ++ show t)+reifyTTUExp t = fail ("Unknown reflection type universe expression: " ++ show t)++-- | Create a reflected call to a named function/constructor+reflCall :: String -> [Raw] -> Raw+reflCall funName args+  = raw_apply (Var (reflm funName)) args++-- | Lift a term into its Language.Reflection.TT representation+reflect :: Term -> Raw+reflect = reflectTTQuote []++-- | Lift a term into its Language.Reflection.Raw representation+reflectRaw :: Raw -> Raw+reflectRaw = reflectRawQuote []++claimTT :: Name -> ElabD Name+claimTT n = do n' <- getNameFrom n+               claim n' (Var (sNS (sUN "TT") ["Reflection", "Language"]))+               return n'++-- | Convert a reflected term to a more suitable form for pattern-matching.+-- In particular, the less-interesting bits are elaborated to _ patterns. This+-- happens to NameTypes, universe levels, names that are bound but not used,+-- and the type annotation field of the P constructor.+reflectTTQuotePattern :: [Name] -> Term -> ElabD ()+reflectTTQuotePattern unq (P _ n _)+  | n `elem` unq = -- the unquoted names have been claimed as TT already - just use them+    do fill (Var n) ; solve+  | otherwise =+    do tyannot <- claimTT (sMN 0 "pTyAnnot")+       movelast tyannot  -- use a _ pattern here+       nt <- getNameFrom (sMN 0 "nt")+       claim nt (Var (reflm "NameType"))+       movelast nt       -- use a _ pattern here+       n' <- getNameFrom (sMN 0 "n")+       claim n' (Var (reflm "TTName"))+       fill $ reflCall "P" [Var nt, Var n', Var tyannot]+       solve+       focus n'; reflectNameQuotePattern n+reflectTTQuotePattern unq (V n)+  = do fill $ reflCall "V" [RConstant (I n)]+       solve+reflectTTQuotePattern unq (Bind n b x)+  = do x' <- claimTT (sMN 0 "sc")+       movelast x'+       b' <- getNameFrom (sMN 0 "binder")+       claim b' (RApp (Var (sNS (sUN "Binder") ["Reflection", "Language"]))+                      (Var (sNS (sUN "TT") ["Reflection", "Language"])))+       if n `elem` freeNames x+         then do fill $ reflCall "Bind"+                                 [reflectName n,+                                  Var b',+                                  Var x']+                 solve+         else do any <- getNameFrom (sMN 0 "anyName")+                 claim any (Var (reflm "TTName"))+                 movelast any+                 fill $ reflCall "Bind"+                                 [Var any,+                                  Var b',+                                  Var x']+                 solve+       focus x'; reflectTTQuotePattern unq x+       focus b'; reflectBinderQuotePattern reflectTTQuotePattern unq b+reflectTTQuotePattern unq (App _ f x)+  = do f' <- claimTT (sMN 0 "f"); movelast f'+       x' <- claimTT (sMN 0 "x"); movelast x'+       fill $ reflCall "App" [Var f', Var x']+       solve+       focus f'; reflectTTQuotePattern unq f+       focus x'; reflectTTQuotePattern unq x+reflectTTQuotePattern unq (Constant c)+  = do fill $ reflCall "TConst" [reflectConstant c]+       solve+reflectTTQuotePattern unq (Proj t i)+  = do t' <- claimTT (sMN 0 "t"); movelast t'+       fill $ reflCall "Proj" [Var t', RConstant (I i)]+       solve+       focus t'; reflectTTQuotePattern unq t+reflectTTQuotePattern unq (Erased)+  = do erased <- claimTT (sMN 0 "erased")+       movelast erased+       fill $ (Var erased)+       solve+reflectTTQuotePattern unq (Impossible)+  = do fill $ Var (reflm "Impossible")+       solve+reflectTTQuotePattern unq (TType exp)+  = do ue <- getNameFrom (sMN 0 "uexp")+       claim ue (Var (sNS (sUN "TTUExp") ["Reflection", "Language"]))+       movelast ue+       fill $ reflCall "TType" [Var ue]+       solve+reflectTTQuotePattern unq (UType u)+  = do uH <- getNameFrom (sMN 0 "someUniv")+       claim uH (Var (reflm "Universe"))+       movelast uH+       fill $ reflCall "UType" [Var uH]+       solve+       focus uH+       fill (Var (reflm (case u of+                           NullType -> "NullType"+                           UniqueType -> "UniqueType"+                           AllTypes -> "AllTypes")))+       solve++reflectRawQuotePattern :: [Name] -> Raw -> ElabD ()+reflectRawQuotePattern unq (Var n)+  -- the unquoted names already have types, just use them+  | n `elem` unq = do fill (Var n); solve+  | otherwise = do fill (reflCall "Var" [reflectName n]); solve+reflectRawQuotePattern unq (RBind n b sc) =+  do scH <- getNameFrom (sMN 0 "sc")+     claim scH (Var (reflm "Raw"))+     movelast scH+     bH <- getNameFrom (sMN 0 "binder")+     claim bH (RApp (Var (reflm "Binder"))+                    (Var (reflm "Raw")))+     if n `elem` freeNamesR sc+        then do fill $ reflCall "RBind" [reflectName n,+                                         Var bH,+                                         Var scH]+                solve+        else do any <- getNameFrom (sMN 0 "anyName")+                claim any (Var (reflm "TTName"))+                movelast any+                fill $ reflCall "RBind" [Var any, Var bH, Var scH]+                solve+     focus scH; reflectRawQuotePattern unq sc+     focus bH; reflectBinderQuotePattern reflectRawQuotePattern unq b+  where freeNamesR (Var n) = [n]+        freeNamesR (RBind n (Let t v) body) = concat [freeNamesR v,+                                                      freeNamesR body \\ [n],+                                                      freeNamesR t]+        freeNamesR (RBind n b body) = freeNamesR (binderTy b) +++                                      (freeNamesR body \\ [n])+        freeNamesR (RApp f x) = freeNamesR f ++ freeNamesR x+        freeNamesR RType = []+        freeNamesR (RUType _) = []+        freeNamesR (RForce r) = freeNamesR r+        freeNamesR (RConstant _) = []+reflectRawQuotePattern unq (RApp f x) =+  do fH <- getNameFrom (sMN 0 "f")+     claim fH (Var (reflm "Raw"))+     movelast fH+     xH <- getNameFrom (sMN 0 "x")+     claim xH (Var (reflm "Raw"))+     movelast xH+     fill $ reflCall "RApp" [Var fH, Var xH]+     solve+     focus fH; reflectRawQuotePattern unq f+     focus xH; reflectRawQuotePattern unq x+reflectRawQuotePattern unq RType =+  do fill (Var (reflm "RType"))+     solve+reflectRawQuotePattern unq (RUType univ) =+  do uH <- getNameFrom (sMN 0 "universe")+     claim uH (Var (reflm "Universe"))+     movelast uH+     fill $ reflCall "RUType" [Var uH]+     solve+     focus uH; fill (reflectUniverse univ); solve+reflectRawQuotePattern unq (RForce r) =+  do rH <- getNameFrom (sMN 0 "raw")+     claim rH (Var (reflm "Raw"))+     movelast rH+     fill $ reflCall "RForce" [Var rH]+     solve+     focus rH; reflectRawQuotePattern unq r+reflectRawQuotePattern unq (RConstant c) =+  do cH <- getNameFrom (sMN 0 "const")+     claim cH (Var (reflm "Constant"))+     movelast cH+     fill (reflCall "RConstant" [Var cH]); solve+     focus cH+     fill (reflectConstant c); solve++reflectBinderQuotePattern :: ([Name] -> a -> ElabD ()) -> [Name] -> Binder a -> ElabD ()+reflectBinderQuotePattern q unq (Lam t)+   = do t' <- claimTT (sMN 0 "ty"); movelast t'+        fill $ reflCall "Lam" [Var (reflm "TT"), Var t']+        solve+        focus t'; q unq t+reflectBinderQuotePattern q unq (Pi _ t k)+   = do t' <- claimTT (sMN 0 "ty") ; movelast t'+        k' <- claimTT (sMN 0 "k"); movelast k';+        fill $ reflCall "Pi" [Var (reflm "TT"), Var t', Var k']+        solve+        focus t'; q unq t+reflectBinderQuotePattern q unq (Let x y)+   = do x' <- claimTT (sMN 0 "ty"); movelast x';+        y' <- claimTT (sMN 0 "v"); movelast y';+        fill $ reflCall "Let" [Var (reflm "TT"), Var x', Var y']+        solve+        focus x'; q unq x+        focus y'; q unq y+reflectBinderQuotePattern q unq (NLet x y)+   = do x' <- claimTT (sMN 0 "ty"); movelast x'+        y' <- claimTT (sMN 0 "v"); movelast y'+        fill $ reflCall "NLet" [Var (reflm "TT"), Var x', Var y']+        solve+        focus x'; q unq x+        focus y'; q unq y+reflectBinderQuotePattern q unq (Hole t)+   = do t' <- claimTT (sMN 0 "ty"); movelast t'+        fill $ reflCall "Hole" [Var (reflm "TT"), Var t']+        solve+        focus t'; q unq t+reflectBinderQuotePattern q unq (GHole _ t)+   = do t' <- claimTT (sMN 0 "ty"); movelast t'+        fill $ reflCall "GHole" [Var (reflm "TT"), Var t']+        solve+        focus t'; q unq t+reflectBinderQuotePattern q unq (Guess x y)+   = do x' <- claimTT (sMN 0 "ty"); movelast x'+        y' <- claimTT (sMN 0 "v"); movelast y'+        fill $ reflCall "Guess" [Var (reflm "TT"), Var x', Var y']+        solve+        focus x'; q unq x+        focus y'; q unq y+reflectBinderQuotePattern q unq (PVar t)+   = do t' <- claimTT (sMN 0 "ty"); movelast t'+        fill $ reflCall "PVar" [Var (reflm "TT"), Var t']+        solve+        focus t'; q unq t+reflectBinderQuotePattern q unq (PVTy t)+   = do t' <- claimTT (sMN 0 "ty"); movelast t'+        fill $ reflCall "PVTy" [Var (reflm "TT"), Var t']+        solve+        focus t'; q unq t++reflectUniverse :: Universe -> Raw+reflectUniverse u =+  (Var (reflm (case u of+                 NullType -> "NullType"+                 UniqueType -> "UniqueType"+                 AllTypes -> "AllTypes")))++-- | Create a reflected TT term, but leave refs to the provided name intact+reflectTTQuote :: [Name] -> Term -> Raw+reflectTTQuote unq (P nt n t)+  | n `elem` unq = Var n+  | otherwise = reflCall "P" [reflectNameType nt, reflectName n, reflectTTQuote unq t]+reflectTTQuote unq (V n)+  = reflCall "V" [RConstant (I n)]+reflectTTQuote unq (Bind n b x)+  = reflCall "Bind" [reflectName n, reflectBinderQuote reflectTTQuote (reflm "TT") unq b, reflectTTQuote unq x]+reflectTTQuote unq (App _ f x)+  = reflCall "App" [reflectTTQuote unq f, reflectTTQuote unq x]+reflectTTQuote unq (Constant c)+  = reflCall "TConst" [reflectConstant c]+reflectTTQuote unq (Proj t i)+  = reflCall "Proj" [reflectTTQuote unq t, RConstant (I i)]+reflectTTQuote unq (Erased) = Var (reflm "Erased")+reflectTTQuote unq (Impossible) = Var (reflm "Impossible")+reflectTTQuote unq (TType exp) = reflCall "TType" [reflectUExp exp]+reflectTTQuote unq (UType u) = reflCall "UType" [reflectUniverse u]++reflectRawQuote :: [Name] -> Raw -> Raw+reflectRawQuote unq (Var n)+  | n `elem` unq = Var n+  | otherwise = reflCall "Var" [reflectName n]+reflectRawQuote unq (RBind n b r) =+  reflCall "RBind" [reflectName n, reflectBinderQuote reflectRawQuote (reflm "Raw") unq b, reflectRawQuote unq r]+reflectRawQuote unq (RApp f x) =+  reflCall "RApp" [reflectRawQuote unq f, reflectRawQuote unq x]+reflectRawQuote unq RType = Var (reflm "RType")+reflectRawQuote unq (RUType u) =+  reflCall "RUType" [reflectUniverse u]+reflectRawQuote unq (RForce r) = reflCall "RForce" [reflectRawQuote unq r]+reflectRawQuote unq (RConstant cst) = reflCall "RConstant" [reflectConstant cst]++reflectNameType :: NameType -> Raw+reflectNameType (Bound) = Var (reflm "Bound")+reflectNameType (Ref) = Var (reflm "Ref")+reflectNameType (DCon x y _)+  = reflCall "DCon" [RConstant (I x), RConstant (I y)] -- FIXME: Uniqueness!+reflectNameType (TCon x y)+  = reflCall "TCon" [RConstant (I x), RConstant (I y)]++reflectName :: Name -> Raw+reflectName (UN s)+  = reflCall "UN" [RConstant (Str (str s))]+reflectName (NS n ns)+  = reflCall "NS" [ reflectName n+                  , foldr (\ n s ->+                             raw_apply ( Var $ sNS (sUN "::") ["List", "Prelude"] )+                                       [ RConstant StrType, RConstant (Str n), s ])+                             ( raw_apply ( Var $ sNS (sUN "Nil") ["List", "Prelude"] )+                                         [ RConstant StrType ])+                             (map str ns)+                  ]+reflectName (MN i n)+  = reflCall "MN" [RConstant (I i), RConstant (Str (str n))]+reflectName NErased = Var (reflm "NErased")+reflectName (SN sn) = raw_apply (Var (reflm "SN")) [reflectSpecialName sn]+reflectName (SymRef _) = error "The impossible happened: symbol table ref survived IBC loading"++reflectSpecialName :: SpecialName -> Raw+reflectSpecialName (WhereN i n1 n2) =+  reflCall "WhereN" [RConstant (I i), reflectName n1, reflectName n2]+reflectSpecialName (WithN i n) = reflCall "WithN" [ RConstant (I i)+                                                  , reflectName n+                                                  ]+reflectSpecialName (InstanceN inst ss) =+  reflCall "InstanceN" [ reflectName inst+                       , mkList (RConstant StrType) $+                           map (RConstant . Str . T.unpack) ss+                       ]+reflectSpecialName (ParentN n s) =+  reflCall "ParentN" [reflectName n, RConstant (Str (T.unpack s))]+reflectSpecialName (MethodN n) =+  reflCall "MethodN" [reflectName n]+reflectSpecialName (CaseN n) =+  reflCall "CaseN" [reflectName n]+reflectSpecialName (ElimN n) =+  reflCall "ElimN" [reflectName n]+reflectSpecialName (InstanceCtorN n) =+  reflCall "InstanceCtorN" [reflectName n]+reflectSpecialName (MetaN parent meta) =+  reflCall "MetaN" [reflectName parent, reflectName meta]++-- | Elaborate a name to a pattern.  This means that NS and UN will be intact.+-- MNs corresponding to will care about the string but not the number.  All+-- others become _.+reflectNameQuotePattern :: Name -> ElabD ()+reflectNameQuotePattern n@(UN s)+  = do fill $ reflectName n+       solve+reflectNameQuotePattern n@(NS _ _)+  = do fill $ reflectName n+       solve+reflectNameQuotePattern (MN _ n)+  = do i <- getNameFrom (sMN 0 "mnCounter")+       claim i (RConstant (AType (ATInt ITNative)))+       movelast i+       fill $ reflCall "MN" [Var i, RConstant (Str $ T.unpack n)]+       solve+reflectNameQuotePattern _ -- for all other names, match any+  = do nameHole <- getNameFrom (sMN 0 "name")+       claim nameHole (Var (reflm "TTName"))+       movelast nameHole+       fill (Var nameHole)+       solve++reflectBinder :: Binder Term -> Raw+reflectBinder = reflectBinderQuote reflectTTQuote (reflm "TT") []++reflectBinderQuote :: ([Name] -> a -> Raw) -> Name -> [Name] -> Binder a -> Raw+reflectBinderQuote q ty unq (Lam t)+   = reflCall "Lam" [Var ty, q unq t]+reflectBinderQuote q ty unq (Pi _ t k)+   = reflCall "Pi" [Var ty, q unq t, q unq k]+reflectBinderQuote q ty unq (Let x y)+   = reflCall "Let" [Var ty, q unq x, q unq y]+reflectBinderQuote q ty unq (NLet x y)+   = reflCall "NLet" [Var ty, q unq x, q unq y]+reflectBinderQuote q ty unq (Hole t)+   = reflCall "Hole" [Var ty, q unq t]+reflectBinderQuote q ty unq (GHole _ t)+   = reflCall "GHole" [Var ty, q unq t]+reflectBinderQuote q ty unq (Guess x y)+   = reflCall "Guess" [Var ty, q unq x, q unq y]+reflectBinderQuote q ty unq (PVar t)+   = reflCall "PVar" [Var ty, q unq t]+reflectBinderQuote q ty unq (PVTy t)+   = reflCall "PVTy" [Var ty, q unq t]++mkList :: Raw -> [Raw] -> Raw+mkList ty []      = RApp (Var (sNS (sUN "Nil") ["List", "Prelude"])) ty+mkList ty (x:xs) = RApp (RApp (RApp (Var (sNS (sUN "::") ["List", "Prelude"])) ty)+                              x)+                        (mkList ty xs)++reflectConstant :: Const -> Raw+reflectConstant c@(I  _) = reflCall "I"  [RConstant c]+reflectConstant c@(BI _) = reflCall "BI" [RConstant c]+reflectConstant c@(Fl _) = reflCall "Fl" [RConstant c]+reflectConstant c@(Ch _) = reflCall "Ch" [RConstant c]+reflectConstant c@(Str _) = reflCall "Str" [RConstant c]+reflectConstant c@(B8 _) = reflCall "B8" [RConstant c]+reflectConstant c@(B16 _) = reflCall "B16" [RConstant c]+reflectConstant c@(B32 _) = reflCall "B32" [RConstant c]+reflectConstant c@(B64 _) = reflCall "B64" [RConstant c]+reflectConstant (AType (ATInt ITNative)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITNative")]]+reflectConstant (AType (ATInt ITBig)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITBig")]]+reflectConstant (AType ATFloat) = reflCall "AType" [Var (reflm "ATFloat")]+reflectConstant (AType (ATInt ITChar)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITChar")]]+reflectConstant StrType = Var (reflm "StrType")+reflectConstant (AType (ATInt (ITFixed IT8)))  = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT8")]]]+reflectConstant (AType (ATInt (ITFixed IT16))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT16")]]]+reflectConstant (AType (ATInt (ITFixed IT32))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT32")]]]+reflectConstant (AType (ATInt (ITFixed IT64))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT64")]]]+reflectConstant VoidType = Var (reflm "VoidType")+reflectConstant Forgot = Var (reflm "Forgot")+reflectConstant WorldType = Var (reflm "WorldType")+reflectConstant TheWorld = Var (reflm "TheWorld")++reflectUExp :: UExp -> Raw+reflectUExp (UVar i) = reflCall "UVar" [RConstant (I i)]+reflectUExp (UVal i) = reflCall "UVal" [RConstant (I i)]++-- | Reflect the environment of a proof into a List (TTName, Binder TT)+reflectEnv :: Env -> Raw+reflectEnv = foldr consToEnvList emptyEnvList+  where+    consToEnvList :: (Name, Binder Term) -> Raw -> Raw+    consToEnvList (n, b) l+      = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"]))+                  [ envTupleType+                  , raw_apply (Var pairCon) [ (Var $ reflm "TTName")+                                            , (RApp (Var $ reflm "Binder")+                                                    (Var $ reflm "TT"))+                                            , reflectName n+                                            , reflectBinder b+                                            ]+                  , l+                  ]++    emptyEnvList :: Raw+    emptyEnvList = raw_apply (Var (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 $ 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 (WithFnType t) = raw_apply (Var $ reflErrName "WithFnType") [reflect t]+reflectErr (CantMatch t) = raw_apply (Var $ reflErrName "CantMatch") [reflect t]+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 (InvalidTCArg n t) = raw_apply (Var $ reflErrName "InvalidTCArg") [reflectName n, reflect t]+reflectErr (CantResolveAlts ss) =+  raw_apply (Var $ reflErrName "CantResolveAlts")+            [rawList (Var $ reflm "TTName") (map reflectName ss)]+reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]+reflectErr (NoEliminator str t) +  = raw_apply (Var $ reflErrName "NoEliminator") [RConstant (Str str),+                                                  reflect t]+reflectErr (UniverseError fc ue old new tys) =+  -- NB: loses information, but OK because this is not likely to be rewritten+  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 (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]++-- | Reflect a file context+reflectFC :: FC -> Raw+reflectFC fc = raw_apply (Var (reflm "FileLoc"))+                         [ RConstant (Str (fc_fname fc))+                         , raw_apply (Var pairCon) $+                             [intTy, intTy] +++                             map (RConstant . I)+                                 [ fst (fc_start fc)+                                 , snd (fc_start fc)+                                 ]+                         , raw_apply (Var pairCon) $+                             [intTy, intTy] +++                             map (RConstant . I)+                                 [ fst (fc_end fc)+                                 , snd (fc_end fc)+                                 ]+                         ]+  where intTy = RConstant (AType (ATInt ITNative))++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 == reflm "TextPart" =+    Right (TextPart msg)+reifyReportPart (App _ (P (DCon _ _ _) n _) ttn)+  | n == reflm "NamePart" =+    case runElab initEState (reifyTTName ttn) (initElaborator NErased initContext emptyContext 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 == reflm "TermPart" =+  case runElab initEState (reifyTT tm) (initElaborator NErased initContext emptyContext 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 == reflm "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++reifyTyDecl :: Term -> ElabD RTyDecl+reifyTyDecl (App _ (App _ (App _ (P (DCon _ _ _) n _) tyN) args) ret)+  | n == tacN "Declare" =+  do tyN'  <- reifyTTName tyN+     args' <- case unList args of+                Nothing -> fail $ "Couldn't reify " ++ show args ++ " as an arglist."+                Just xs -> mapM reifyRArg xs+     ret'  <- reifyRaw ret+     return $ RDeclare tyN' args' ret'+  where reifyRArg :: Term -> ElabD RArg+        reifyRArg (App _ (App _ (P (DCon _ _ _) n _) argN) argTy)+          | n == tacN "Explicit"   = liftM2 RExplicit+                                            (reifyTTName argN)+                                            (reifyRaw argTy)+          | n == tacN "Implicit"   = liftM2 RImplicit+                                            (reifyTTName argN)+                                            (reifyRaw argTy)                               | n == tacN "Constraint" = liftM2 RConstraint+                                            (reifyTTName argN)+                                            (reifyRaw argTy)+        reifyRArg aTm = fail $ "Couldn't reify " ++ show aTm ++ " as an RArg."+reifyTyDecl tm = fail $ "Couldn't reify " ++ show tm ++ " as a type declaration."++reifyFunDefn :: Term -> ElabD RFunDefn+reifyFunDefn (App _ (App _ (P _ n _) fnN) clauses)+  | n == tacN "DefineFun" =+  do fnN' <- reifyTTName fnN+     clauses' <- case unList clauses of+                   Nothing -> fail $ "Couldn't reify " ++ show clauses ++ " as a clause list"+                   Just cs -> mapM reifyC cs+     return $ RDefineFun fnN' clauses'+  where reifyC :: Term -> ElabD RFunClause+        reifyC (App _ (App _ (P (DCon _ _ _) n _) lhs) rhs)+          | n == tacN "MkFunClause" = liftM2 RMkFunClause+                                             (reifyRaw lhs)+                                             (reifyRaw rhs)+        reifyC (App _ (P (DCon _ _ _) n _) lhs)+          | n == tacN "MkImpossibleClause" = fmap RMkImpossibleClause $ reifyRaw lhs+        reifyC tm = fail $ "Couldn't reify " ++ show tm ++ " as a clause."+reifyFunDefn tm = fail $ "Couldn't reify " ++ show tm ++ " as a function declaration."++envTupleType :: Raw+envTupleType+  = raw_apply (Var pairTy) [ (Var $ reflm "TTName")+                           , (RApp (Var $ reflm "Binder") (Var $ reflm "TT"))+                           ]++-- | Build the reflected datatype definition(s) that correspond(s) to+-- a provided unqualified name+buildDatatypes :: Context -> Ctxt TypeInfo -> Name -> [RDatatype]+buildDatatypes ctxt datatypes n =+  catMaybes [ mkDataType dn ti+            | (dn, ti) <- lookupCtxtName n datatypes+            ]+  where mkDataType name (TI {param_pos = params, con_names = constrs}) =+          do (TyDecl (TCon _ _) ty) <- lookupDefExact name ctxt+             let (tcargs, tcres) = getArgs params (forget ty) 0+             conTys <- mapM (fmap forget . flip lookupTyExact ctxt) constrs+             return $ RDatatype name tcargs tcres $ zip constrs conTys++        getArgs params (RBind an (Pi _ ty _) body) i =+          let (args, res) = getArgs params body (i+1)+          in if i `elem` params+               then (RParameter an ty : args, res )+               else (RIndex an ty : args, res)+        getArgs _ tm _ = ([], tm)++reflectDatatype :: RDatatype -> Raw+reflectDatatype (RDatatype tyn tyConArgs tyConRes constrs) =+  raw_apply (Var $ tacN "MkDatatype") [ reflectName tyn+                                      , rawList (Var $ tacN "TyConArg") (map reflectConArg tyConArgs)+                                      , reflectRaw tyConRes+                                      , rawList (rawPairTy (Var $ reflm "TTName") (Var $ reflm "Raw"))+                                                [ rawPair ((Var $ reflm "TTName"), (Var $ reflm "Raw"))+                                                          (reflectName cn, reflectRaw cty)+                                                | (cn, cty) <- constrs+                                                ]+                                      ]+  where reflectConArg (RParameter n t) =+          raw_apply (Var $ tacN "Parameter") [reflectName n, reflectRaw t]+        reflectConArg (RIndex n t) =+          raw_apply (Var $ tacN "Index")     [reflectName n, reflectRaw t]
src/Idris/Transforms.hs view
@@ -39,21 +39,21 @@    = finalise $ applyAll rules emptyContext (vToP tm)  applyAll :: [(Term, Term)] -> Ctxt [(Term, Term)] -> Term -> Term-applyAll extra ts ap@(App f a) +applyAll extra ts ap@(App s f a)      | (P _ fn ty, args) <- unApply ap          = let rules = case lookupCtxtExact fn ts of                             Just r -> extra ++ r                             Nothing -> extra -               ap' = App (applyAll extra ts f) (applyAll extra ts a) in+               ap' = App s (applyAll extra ts f) (applyAll extra ts a) in                case rules of                     [] -> ap'                     rs -> case applyFnRules rs ap of-                                   Just tm'@(App f' a') ->-                                     App (applyAll extra ts f')-                                         (applyAll extra ts a')+                                   Just tm'@(App s f' a') ->+                                     App s (applyAll extra ts f')+                                           (applyAll extra ts a')                                    Just tm' -> tm'-                                   _ -> App (applyAll extra ts f) -                                            (applyAll extra ts a)+                                   _ -> App s (applyAll extra ts f) +                                              (applyAll extra ts a) applyAll extra ts (Bind n b sc) = Bind n (fmap (applyAll extra ts) b)                                           (applyAll extra ts sc) applyAll extra ts t = t@@ -94,7 +94,7 @@       doMatch :: [Name] -> Term -> Term -> Maybe [(Name, Term)]       doMatch ns (P _ n _) tm            | n `elem` ns = return [(n, tm)]-      doMatch ns (App f a) (App f' a')+      doMatch ns (App _ f a) (App _ f' a')            = do fm <- doMatch ns f f'                 am <- doMatch ns a a'                 return (fm ++ am)
src/Idris/TypeSearch.hs view
@@ -30,7 +30,7 @@ import Idris.Delaborate (delabTy) import Idris.Docstrings (noDocs, overview) import Idris.Elab.Type (elabType)-import Idris.Output (iputStrLn, iRenderOutput, iPrintResult, iRenderResult, prettyDocumentedIst)+import Idris.Output (iputStrLn, iRenderOutput, iPrintResult, iRenderError, iRenderResult, prettyDocumentedIst) import Idris.IBC  import Prelude hiding (pred)@@ -47,17 +47,19 @@   pterm' <- addUsingConstraints syn emptyFC pterm   pterm'' <- implicit toplevel syn name pterm'   let pterm'''  = addImpl [] i pterm''-  ty <- elabType toplevel syn (fst noDocs) (snd noDocs) emptyFC [] name pterm'+  ty <- elabType toplevel syn (fst noDocs) (snd noDocs) emptyFC [] name NoFC pterm'   let names = searchUsing searchPred i ty   let names' = take numLimit names   let docs =        [ let docInfo = (n, delabTy i n, fmap (overview . fst) (lookupCtxtExact n (idris_docstrings i))) in          displayScore theScore <> char ' ' <> prettyDocumentedIst i docInfo                 | (n, theScore) <- names']-  case idris_outputmode i of-    RawOutput _  -> do mapM_ iRenderOutput docs-                       iPrintResult ""-    IdeMode _ _ -> iRenderResult (vsep docs)+  if (not (null docs))+     then case idris_outputmode i of+               RawOutput _  -> do mapM_ iRenderOutput docs+                                  iPrintResult ""+               IdeMode _ _ -> iRenderResult (vsep docs)+     else iRenderError $ text "No results found"   putIState i -- don't actually make any changes   where     numLimit = 50@@ -102,9 +104,9 @@ -- Replace all occurences of `Lazy' s t` with `t` in a type unLazy :: Type -> Type unLazy typ = case typ of-  App (App (P _ lazy _) _) ty | lazy == sUN "Lazy'" -> unLazy ty+  App _ (App _ (P _ lazy _) _) ty | lazy == sUN "Lazy'" -> unLazy ty   Bind name binder ty -> Bind name (fmap unLazy binder) (unLazy ty)-  App t1 t2 -> App (unLazy t1) (unLazy t2)+  App s t1 t2 -> App s (unLazy t1) (unLazy t2)   Proj ty i -> Proj (unLazy ty) i   _ -> typ @@ -144,7 +146,7 @@     Let t v ->   f b t `M.union` f b v     Guess t v -> f b t `M.union` f b v     bind -> f b (binderTy bind)-  f b (App t1 t2) = f b t1 `M.union` f (b && isInjective t1) t2+  f b (App _ t1 t2) = f b t1 `M.union` f (b && isInjective t1) t2   f b (Proj t _) = f b t   f _ (V _) = error "unexpected! run vToP first"   f _ _ = M.empty@@ -305,13 +307,14 @@ -- recalls the number of flips that have been made flipEqualities :: Type -> [(Int, Type)] flipEqualities t = case t of-  eq1@(App (App (App (App eq@(P _ eqty _) tyL) tyR) valL) valR) | eqty == eqTy ->-    [(0, eq1), (1, App (App (App (App eq tyR) tyL) valR) valL)]+  eq1@(App _ (App _ (App _ (App _ eq@(P _ eqty _) tyL) tyR) valL) valR) | eqty == eqTy ->+    [(0, eq1), (1, app (app (app (app eq tyR) tyL) valR) valL)]   Bind n binder sc -> (\bind' (j, sc') -> (fst (binderTy bind') + j, Bind n (fmap snd bind') sc'))     <$> traverse flipEqualities binder <*> flipEqualities sc-  App f x -> (\(i, f') (j, x') -> (i + j, App f' x')) +  App _ f x -> (\(i, f') (j, x') -> (i + j, app f' x'))      <$> flipEqualities f <*> flipEqualities x   t' -> [(0, t')]+ where app = App Complete  --DONT run vToP first! -- | Try to match two types together in a unification-like procedure.@@ -436,7 +439,7 @@     className <- getClassName clss     classDef <- lookupCtxt className classInfo     n <- class_instances classDef-    def <- lookupCtxt n (definitions ctxt)+    def <- lookupCtxt (fst n) (definitions ctxt)     nty <- normaliseC ctxt [] <$> (case typeFromDef def of Just x -> [x]; Nothing -> [])     let ty' = vToP (uniqueBinders usedns nty)     return ty'
src/Idris/WhoCalls.hs view
@@ -13,7 +13,7 @@ occurs n (P Bound _ _) = False occurs n (P _ n' _) = n == n' occurs n (Bind _ b sc) = occursBinder n b || occurs n sc-occurs n (App t1 t2) = occurs n t1 || occurs n t2+occurs n (App _ t1 t2) = occurs n t1 || occurs n t2 occurs n (Proj t _) = occurs n t occurs n _ = False @@ -21,7 +21,7 @@ names (P Bound _ _) = [] names (P _ n _) = [n] names (Bind _ b sc) = namesBinder b ++ names sc-names (App t1 t2) = names t1 ++ names t2+names (App _ t1 t2) = names t1 ++ names t2 names (Proj t _) = names t names _ = []
src/Pkg/PParser.hs view
@@ -5,12 +5,12 @@  module Pkg.PParser where -import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)+import Text.Trifecta hiding (span, charLiteral, natural, symbol, char, string, whiteSpace)  import Idris.Core.TT import Idris.REPL import Idris.AbsSyntaxTree-import Idris.ParseHelpers+import Idris.ParseHelpers hiding (stringLiteral) import Idris.CmdOptions  import Control.Monad.State.Strict@@ -34,6 +34,9 @@                        }     deriving Show +instance HasLastTokenSpan PParser where+  getLastTokenSpan = return Nothing+ #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} TokenParsing PParser where #else@@ -51,7 +54,7 @@                        Success x -> return x  pPkg :: PParser PkgDesc-pPkg = do reserved "package"; p <- identifier+pPkg = do reserved "package"; p <- fst <$> identifier           st <- get           put (st { pkgname = p })           some pClause@@ -61,18 +64,18 @@  pClause :: PParser () pClause = do reserved "executable"; lchar '=';-             exec <- iName []+             exec <- fst <$> iName []              st <- get              put (st { execout = Just (if isWindows                                           then ((show exec) ++ ".exe")                                           else ( show exec )                                       ) })       <|> do reserved "main"; lchar '=';-             main <- iName []+             main <- fst <$> iName []              st <- get              put (st { idris_main = main })       <|> do reserved "sourcedir"; lchar '=';-             src <- identifier+             src <- fst <$> identifier              st <- get              put (st { sourcedir = src })       <|> do reserved "opts"; lchar '=';@@ -81,23 +84,23 @@              let args = pureArgParser (words opts)              put (st { idris_opts = args })       <|> do reserved "modules"; lchar '=';-             ms <- sepBy1 (iName []) (lchar ',')+             ms <- sepBy1 (fst <$> iName []) (lchar ',')              st <- get              put (st { modules = modules st ++ ms })       <|> do reserved "libs"; lchar '=';-             ls <- sepBy1 identifier (lchar ',')+             ls <- sepBy1 (fst <$> identifier) (lchar ',')              st <- get              put (st { libdeps = libdeps st ++ ls })       <|> do reserved "objs"; lchar '=';-             ls <- sepBy1 identifier (lchar ',')+             ls <- sepBy1 (fst <$> identifier) (lchar ',')              st <- get              put (st { objs = libdeps st ++ ls })       <|> do reserved "makefile"; lchar '=';-             mk <- iName []+             mk <- fst <$> iName []              st <- get              put (st { makefile = Just (show mk) })       <|> do reserved "tests"; lchar '=';-             ts <- sepBy1 (iName []) (lchar ',')+             ts <- sepBy1 (fst <$> iName []) (lchar ',')              st <- get              put st { idris_tests = idris_tests st ++ ts }
+ src/Tools_idris.hs view
@@ -0,0 +1,4 @@+module Tools_idris where++hasBundledToolchain = False+getToolchainDir = ""
src/Util/System.hs view
@@ -1,4 +1,6 @@-module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows) where+{-# LANGUAGE CPP #-}+module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows,+                writeSource, readSource, setupBundledCC) where  -- System helper functions. import Control.Monad (when)@@ -6,13 +8,19 @@                         , removeFile                         , removeDirectoryRecursive                         , createDirectoryIfMissing+                        , doesDirectoryExist                         )-import System.FilePath ((</>), normalise)+import System.FilePath ((</>), normalise, isAbsolute, dropFileName) import System.IO import System.Info import System.IO.Error import Control.Exception as CE +#ifdef FREESTANDING+import Tools_idris+import System.Environment (getEnv, setEnv, getExecutablePath)+#endif+ catchIO :: IO a -> (IOError -> IO a) -> IO a catchIO = CE.catch @@ -26,6 +34,16 @@ tempfile = do dir <- getTemporaryDirectory               openTempFile (normalise dir) "idris" +-- | Read a source file, same as readFile but make sure the encoding is utf-8.+readSource :: FilePath -> IO String+readSource f = do h <- openFile f ReadMode+                  hSetEncoding h utf8+                  hGetContents h++-- | Write a source file, same as writeFile except the encoding is set to utf-8+writeSource :: FilePath -> String -> IO ()+writeSource f s = withFile f WriteMode (\h -> hSetEncoding h utf8 >> hPutStr h s)+ withTempdir :: String -> (FilePath -> IO a) -> IO a withTempdir subdir callback   = do dir <- getTemporaryDirectory@@ -43,3 +61,24 @@               catchIO (removeFile f)                       (\ioerr -> putStrLn $ "WARNING: Cannot remove file "                                  ++ f ++ ", Error msg:" ++ show ioerr)++setupBundledCC :: IO()+#ifdef FREESTANDING+setupBundledCC = when hasBundledToolchain+                    $ do+                        exePath <- getExecutablePath+                        path <- getEnv "PATH"+                        tcDir <- return getToolchainDir+                        absolute <- return $ isAbsolute tcDir+                        target <- return $+                                    if absolute+                                       then tcDir+                                       else dropFileName exePath ++ tcDir+                        let pathSep = if isWindows then ";" else ":"+                        present <- doesDirectoryExist target+                        when present+                            $ do newPath <- return $ target ++ pathSep ++ path+                                 setEnv "PATH" newPath+#else+setupBundledCC = return ()+#endif
test/Makefile view
@@ -8,7 +8,7 @@ 	@perl ./runtest.pl $(patsubst %.test,%,$@)  test_js:-	@perl ./runtest.pl without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 effects003 buffer001 basic007 basic011 primitives004 ffi006 --codegen node+	@perl ./runtest.pl without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 effects003 effects004 basic007 basic011 primitives004 ffi006 --codegen node  update: 	/usr/bin/env perl ./runtest.pl all -u
test/basic009/expected view
@@ -1,5 +1,4 @@ MAIN-PASS Faulty.idr:6:7:When elaborating type of Faulty.fault:-When elaborating argument x to type constructor =:-        Can't disambiguate name: A.num, B.C.num+Can't disambiguate name: A.num, B.C.num Multiple.idr:3:1:import alias not unique: "X"
test/basic010/Main.idr view
@@ -38,6 +38,6 @@  main : IO () main = do-    n <- map (const 10000) (putStrLn "*oink*")+    n <- map (const (the Nat 10000)) (putStrLn "*oink*")     putStrLn . show $ getWitness (f 4 n)     putStrLn . fmt  $ getProof   (g 4 n)
test/basic010/run view
@@ -1,35 +1,41 @@ #!/usr/bin/env bash -# From http://unix.stackexchange.com/questions/43340/how-to-introduce-timeout-for-shell-scripting-# Here copied from reg039.-#-# Executes command with a timeout-# Params:-#   $1 timeout in seconds-#   $2 command-# Returns 1 if timed out 0 otherwise-timeout() { -    time=$1--    # start the command in a subshell to avoid problem with pipes-    # (spawn accepts one command)-    command="/bin/sh -c \"$2\""--    expect -c "set echo \"-noecho\"; set timeout $time; spawn -noecho $command; expect timeout { exit 1 } eof { exit 0 }"--    if [ $? = 1 ] ; then-        echo "Timeout after ${time} seconds"-    fi--}- declare -a extraargs for arg in "$@" do     extraargs=("${extraargs[@]}" "'$arg'") done -timeout 10 "idris ${extraargs[*]} Main.idr --nocolour --check --warnreach -o basic010"-timeout 5  "./basic010"+if (which timeout&>/dev/null); then+    timeout 10 idris $@ Main.idr --nocolour --check --warnreach -o basic010+    timeout 5  ./basic010+else+    # From http://unix.stackexchange.com/questions/43340/how-to-introduce-timeout-for-shell-scripting+    # Here copied from reg039.+    #+    # Executes command with a timeout+    # Params:+    #   $1 timeout in seconds+    #   $2 command+    # Returns 1 if timed out 0 otherwise+    timeout() {++        time=$1++        # start the command in a subshell to avoid problem with pipes+        # (spawn accepts one command)+        command="/bin/sh -c \"$2\""++        expect -c "set echo \"-noecho\"; set timeout $time; spawn -noecho $command; expect timeout { exit 1 } eof { exit 0 }"++        if [ $? = 1 ] ; then+            echo "Timeout after ${time} seconds"+        fi++    }++    timeout 10 "idris ${extraargs[*]} Main.idr --nocolour --check --warnreach -o basic010"+    timeout 5  "./basic010"+fi rm -f *.ibc basic010
+ test/basic013/basic013.idr view
@@ -0,0 +1,34 @@+foo : String+foo = "λx→x"++bar : String+bar = "λx→x"++baz : Char+baz = 'λ'++quux : String+quux = "\x0a\x80\xC9\xFF\n3\n4"++appMany : Nat -> String+appMany Z = foo+appMany (S k) = bar ++ appMany k++main : IO ()+main = do putStrLn foo+          putStrLn (foo ++ bar)+          putStrLn (reverse (foo ++ bar))+          printLn (length foo)+          printLn baz+          let x = 4+          let newstr = appMany (toNat x)+          putStrLn newstr+          printLn (strHead newstr)+          printLn (length newstr)+          printLn (strIndex newstr 4)+          putStrLn (strCons (strIndex newstr 4) "")+          putStrLn ("Tail: " ++ strTail newstr)+          putStrLn ("Tail Tail: " ++ strTail (strTail newstr))+          putStrLn ("Cons: " ++ strCons 'λ' newstr)+          putStrLn ("Reverse: " ++ reverse newstr)+
+ test/basic013/expected view
@@ -0,0 +1,14 @@+λx→x+λx→xλx→x+x→xλx→xλ+4+'\955'+λx→xλx→xλx→xλx→xλx→x+'\955'+20+'\955'+λ+Tail: x→xλx→xλx→xλx→xλx→x+Tail Tail: →xλx→xλx→xλx→xλx→x+Cons: λλx→xλx→xλx→xλx→xλx→x+Reverse: x→xλx→xλx→xλx→xλx→xλ
+ test/basic013/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ basic013.idr -o basic013+./basic013+rm -f basic013 *.ibc
+ test/bignum001/bignum001.idr view
@@ -0,0 +1,17 @@+module Main++fac : Integer -> Integer+fac 0 = 1+fac n = n*fac(n-1)++binomial : Integer -> Integer -> Integer+binomial n k = divBigInt (fac n) ((fac k)*(fac (n-k)))++sumBinomials : Integer -> Integer+sumBinomials n = foldr (+) 0 (map (\k=>binomial n k) [0..n])++main : IO ()+main = do+	if sumBinomials 1000 - pow 2 1000 == 0 +		then putStrLn "OK"+		else putStrLn "ERROR"
+ test/bignum001/expected view
@@ -0,0 +1,1 @@+OK
+ test/bignum001/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ bignum001.idr -o bignum001+./bignum001+rm -f bignum001 *.ibc
+ test/bignum002/bignum002.idr view
@@ -0,0 +1,5 @@+module Main++main : IO ()+main = do+    putStrLn $ show $ divNat 1809022195644390369852458 91238741987
+ test/bignum002/expected view
@@ -0,0 +1,1 @@+19827346982734
+ test/bignum002/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ bignum002.idr -o bignum002+./bignum002+rm -f bignum002 *.ibc
− test/buffer001-disabled/buffer001.idr 
@@ -1,45 +0,0 @@-module Main--import Data.Buffer--em : Buffer 0-em = allocate 4--one : Bits32-one = 1--two : Bits8-two = 2--firstHalf : Buffer 4-firstHalf = appendBits32LE em 1 one--full : Buffer 8-full = appendBits8 firstHalf 4 two--firstByte : Bits8-firstByte = peekBits8 full 0--firstHalfView : Buffer 4-firstHalfView = peekBuffer full 0--firstHalfCopy : Buffer 4-firstHalfCopy = copy firstHalfView--oneFromFirstHalf : Bits32-oneFromFirstHalf = peekBits32LE firstHalf 0--oneFromFirstHalfCopy : Bits32-oneFromFirstHalfCopy = peekBits32LE firstHalfCopy 0--viewsAndCopiesPreserveEquality : Bool-viewsAndCopiesPreserveEquality = ( oneFromFirstHalf == one ) && ( oneFromFirstHalfCopy == one )--secondHalfWord : Bits32-secondHalfWord = peekBits32LE full 4--main : IO ()-main = do-  putStrLn $ show firstByte-  putStrLn $ show viewsAndCopiesPreserveEquality-  putStrLn $ show secondHalfWord
− test/buffer001-disabled/expected 
@@ -1,3 +0,0 @@-01-True-02020202
− test/buffer001-disabled/run 
@@ -1,4 +0,0 @@-#!/usr/bin/env bash-idris $@ buffer001.idr -o buffer001-./buffer001-rm -f buffer001 *.ibc
+ test/classes001/ClassName.idr view
@@ -0,0 +1,49 @@+module ClassName++||| A fancy shower with a constructor+||| @ a the thing to be shown+class MyShow a where+  ||| Build a MyShow+  constructor MkMyShow+  ||| The shower+  ||| @ x will become a string+  myShow : (x : a) -> String++twiceAString : MyShow a => a -> String+twiceAString x = myShow x ++ myShow x++instance MyShow Integer where+  myShow x = show x++badShow : MyShow Integer+badShow = MkMyShow (const "hej")++test1 : twiceAString 2 = "22"+test1 = Refl++test2 : twiceAString @{badShow} 2 = "hejhej"+test2 = Refl+++||| Superclass fun+class MyMagma a where+  constructor MkMyMagma+  total op : a -> a -> a++||| Semigroup+class MyMagma a => MySemigroup a where+  constructor MkMySemigroup+  total isAssoc : (x, y, z : a) -> op x $ op y z = op (op x y) z++instance [addition] MyMagma Nat where+  op = plus++additionS : MySemigroup Nat+additionS = MkMySemigroup @{addition} plusAssociative++doIt : MySemigroup a => a -> List a -> a+doIt x [] = x+doIt x (y :: xs) = doIt (x `op` y) xs++test : Nat+test = doIt @{additionS} 22 [1,2,3,4]
+ test/classes001/expected view
@@ -0,0 +1,27 @@+Type class MyShow+    A fancy shower with a constructor++Parameters:+    a   -- the thing to be shown++Methods:+    myShow : MyShow a => (x : a) -> String+        The shower+        +Instance constructor:+    MkMyShow : (myShow : a -> String) -> MyShow a+        Build a MyShow+        Arguments:+            (implicit) a : Type  -- the thing to be shown+            +            myShow : a -> String  -- The shower+            +Instances:+    MyShow Integer+MkMyShow : (myShow : a -> String) -> MyShow a+    Build a MyShow+    Arguments:+        (implicit) a : Type  -- the thing to be shown+        +        myShow : a -> String  -- The shower+
+ test/classes001/input view
@@ -0,0 +1,2 @@+:doc MyShow+:doc MkMyShow
+ test/classes001/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --quiet --nocolour --consolewidth 70 ClassName.idr < input+rm -f bounded001 *.ibc
+ test/corecords001/corecords001.idr view
@@ -0,0 +1,24 @@+module Main++corecord Str a where -- Current stream is codata, not a corecord+  constructor (::)+  head : a+  tail : Str a++instance Functor Str where+  map f (x :: xs) = (f x) :: (map f xs)++total -- marked total to check that corecords are indeed treated as coinductive types+zeros : Str Int+zeros = 0 :: zeros++ones : Str Int+ones = map (1+) zeros++main : IO ()+main = do let x = record { head = 1 } zeros+          printLn $ head zeros+          printLn $ head x+          printLn $ head (record { head = 3 } x)+          printLn $ head (tail ones)+          printLn $ head (tail (record { tail = zeros } ones))
+ test/corecords001/expected view
@@ -0,0 +1,5 @@+0+1+3+1+0
+ test/corecords001/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ corecords001.idr -o corecords001+./corecords001+rm -f corecords001 corecords001.ibc
+ test/corecords002/corecords002.idr view
@@ -0,0 +1,24 @@+module Main++corecord Foo (n : Nat) where+  constructor MkFoo+  bar : String+  baz : Foo n+  +corecord Blargh where+  constructor MkBlargh+  num : Nat+  argh : Foo num+  +total  +foo : Foo 7+foo = MkFoo "Foo" foo  ++total+blargh : Blargh+blargh = MkBlargh 7 foo+  +main : IO ()+main = do printLn (record { argh->bar } blargh)+          printLn (record { argh->baz->bar } blargh)+          printLn (record { argh->baz->baz->bar } blargh)
+ test/corecords002/expected view
@@ -0,0 +1,3 @@+"Foo"+"Foo"+"Foo"
+ test/corecords002/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ corecords002.idr -o corecords002+./corecords002+rm -f corecords002 corecords002.ibc
test/delab001/expected view
@@ -1,4 +1,3 @@-Type checking ./delab001.idr foo : Nat -> String foo n = case n of           0 => "z"
test/docs001/expected view
@@ -1,4 +1,3 @@-Type checking ./docs001.idr Type class C     class
test/docs002/expected view
@@ -1,11 +1,9 @@-Type checking ./docs002.idr-*docs002> T1 : Type+T1 : Type     Some documentation     -*docs002> T2 : Type+T2 : Type     Some other documentation     -*docs002> T3 : Int+T3 : Int     Some provided postulate     -*docs002> Bye bye
test/docs002/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 --nobanner --nocolor docs002.idr < input+idris --consolewidth 80 --nobanner --nocolor --quiet docs002.idr < input rm *.ibc
test/docs003/expected view
@@ -1,4 +1,3 @@-Type checking ./docs003.idr Type class Functor     Functors
test/dsl002/expected view
@@ -1,2 +1,1 @@ foo-
test/dsl002/test014.idr view
@@ -11,7 +11,7 @@ data FILE : Purpose -> Type where     OpenH : File -> FILE p -syntax ifM [test] then [t] else [e]+syntax "ifM" [test] "then" [t] "else" [e]     = test >>= (\b => if b then t else e)  open : String -> (p:Purpose) -> Creator (Either () (FILE p))@@ -34,8 +34,9 @@ syntax reof [h]      = Use eof h  syntax rputStrLn [s] = Lift (putStrLn s)+syntax rputStr [s] = Lift (putStr s) -syntax if opened [f] then [e] else [t] = Check f t e+syntax "if" "opened" [f] "then" [e] "else" [t] = Check f t e   @@ -57,7 +58,7 @@ readH fn = res (do let x = open fn Reading                    if opened x then                        do str <- rreadLine x-                          rputStrLn str+                          rputStr str                           rclose x                        else rputStrLn "Error")
test/effects001/test021.idr view
@@ -9,8 +9,7 @@ data Count : Type where  FileIO : Type -> Type -> Type-FileIO st t-   = { [FILE_IO st, STDIO, Count ::: STATE Int] } Eff t+FileIO st t = Eff t [FILE_IO st, STDIO, Count ::: STATE Int]  readFile : FileIO (OpenFile Read) (List String) readFile = readAcc [] where@@ -29,6 +28,6 @@               putStrLn (show !(Count :- get))  main : IO ()-main = run testFile+main = run testFile
test/effects001/test021a.idr view
@@ -18,7 +18,7 @@ -- Evaluator t --    = Eff m [EXCEPTION String, RND, STATE Env] t -eval : Expr -> { [EXCEPTION String, STDIO, RND, STATE Env] } Eff Integer+eval : Expr -> Eff Integer [EXCEPTION String, STDIO, RND, STATE Env] eval (Var x) = do vs <- get                   case lookup x vs of                         Nothing => raise ("No such variable " ++ x)
test/effects002/test025.idr view
@@ -6,8 +6,8 @@ import Data.Vect  MemoryIO : Type -> Type -> Type -> Type-MemoryIO td ts r = { [ Dst ::: RAW_MEMORY td-                     , Src ::: RAW_MEMORY ts ] } Eff r+MemoryIO td ts r = Eff r [Dst ::: RAW_MEMORY td,+                          Src ::: RAW_MEMORY ts]  inpVect : Vect 5 Bits8 inpVect = map prim__truncInt_B8 [0, 1, 2, 3, 5]
test/effects003/hangman.idr view
@@ -74,55 +74,59 @@ -- the number of missing letters, if not, reduce the number of guesses left       Guess : (x : Char) ->-             { Hangman (Running (S g) (S w)) ==>-               {inword} (case inword of-                             True => Hangman (Running (S g) w)-                             False => Hangman (Running g (S w))) }-                HangmanRules Bool+             sig HangmanRules Bool+                 (Hangman (Running (S g) (S w)))+                 (\inword =>+                        Hangman (case inword of+                             True => (Running (S g) w)+                             False => (Running g (S w))))  -- The 'Won' operation requires that there are no missing letters -     Won  : { Hangman (Running g 0) ==> Hangman NotRunning } HangmanRules ()+     Won  : sig HangmanRules ()+                (Hangman (Running g 0))+                (Hangman NotRunning)  -- The 'Lost' operation requires that there are no guesses left -     Lost : { Hangman (Running 0 g) ==> Hangman NotRunning } HangmanRules ()+     Lost : sig HangmanRules ()+                (Hangman (Running 0 g))+                (Hangman NotRunning)  -- Set up a new game, initialised with 6 guesses and the missing letters in -- the given word. Note that if there are no letters in the word, we won't -- be able to run 'Guess'!       NewWord : (w : String) -> -               { h ==> Hangman (Running 6 (length (letters w))) } HangmanRules ()+               sig HangmanRules () h (Hangman (Running 6 (length (letters w))))  -- Finally, allow us to get the current game state      -     Get  : { h } HangmanRules h+     Get  : sig HangmanRules h h  HANGMAN : HState -> EFFECT HANGMAN h = MkEff (Hangman h) HangmanRules  -- Promote explicit effecst to Eff programs -guess : Char ->-        { [HANGMAN (Running (S g) (S w))] ==>-          {inword} [HANGMAN (case inword of-                                  True => Running (S g) w-                                  False => Running g (S w))] } Eff Bool+guess : Char -> Eff Bool+                [HANGMAN (Running (S g) (S w))]+                (\inword => [HANGMAN (case inword of+                                        True => Running (S g) w+                                        False => Running g (S w))]) guess c = call (Main.Guess c) -won : { [HANGMAN (Running g 0)] ==> [HANGMAN NotRunning]} Eff ()+won :  Eff () [HANGMAN (Running g 0)] [HANGMAN NotRunning] won = call Won -lost : { [HANGMAN (Running 0 g)] ==> [HANGMAN NotRunning]} Eff ()+lost : Eff () [HANGMAN (Running 0 g)] [HANGMAN NotRunning] lost = call Lost -new_word : (w : String) ->-           { [HANGMAN h] ==> -             [HANGMAN (Running 6 (length (letters w)))]} Eff ()+new_word : (w : String) -> Eff () [HANGMAN h] +                                  [HANGMAN (Running 6 (length (letters w)))] new_word w = call (NewWord w) -get : { [HANGMAN h] } Eff (Hangman h)+get : Eff (Hangman h) [HANGMAN h] get = call Get  -----------------------------------------------------------------------@@ -163,8 +167,8 @@ soRefl : So x -> (x = True) soRefl Oh = Refl  -game : { [HANGMAN (Running (S g) w), STDIO] ==> -         [HANGMAN NotRunning, STDIO] } Eff ()+game : Eff () [HANGMAN (Running (S g) w), STDIO]+              [HANGMAN NotRunning, STDIO] game {w=Z} = won  game {w=S _}      = do putStrLn (show !get)@@ -175,10 +179,8 @@                (Right p) => do putStrLn "Invalid input!"                                game   where -    processGuess : -- {g,w:_} ->-                   Char -> { [HANGMAN (Running (S g) (S w)), STDIO] ==> -                             [HANGMAN NotRunning, STDIO] }-                           Eff ()+    processGuess : Char -> Eff () [HANGMAN (Running (S g) (S w)), STDIO] +                                  [HANGMAN NotRunning, STDIO]      processGuess {g} c {w}       = case !(guess c) of              True => do putStrLn "Good guess!"@@ -203,7 +205,7 @@  {- It typechecks! Ship it! -} -runGame : { [HANGMAN NotRunning, RND, STDIO] } Eff ()+runGame : Eff () [HANGMAN NotRunning, RND, STDIO] runGame = do srand 1234567890               let w = index !(rndFin _) words              new_word w
+ test/effects004/effects004.idr view
@@ -0,0 +1,19 @@+import Effects+import Effect.StdIO+import Effect.State++counter : Eff () [STATE Int, STDIO]+counter = do putStrLn $ "Counter at " ++ show !get+             x <- getStr+             if trim x /= "" then pure ()+                             else do put (!get + 1)+                                     counter++startCounter : Eff () [STDIO]+startCounter = do putStrLn "Off we go!"+                  new (STATE Int) 0 counter+                  putStrLn "Finished!"++main : IO ()+main = run startCounter+
+ test/effects004/expected view
@@ -0,0 +1,11 @@+Off we go!+Counter at 0+Counter at 1+Counter at 2+Counter at 3+Counter at 4+Counter at 5+Counter at 6+Counter at 7+Counter at 8+Finished!
+ test/effects004/input view
@@ -0,0 +1,10 @@+++++++++done+
+ test/effects004/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ effects004.idr -o effects004 -p effects+./effects004 < input+rm -f effects004 *.ibc
test/error001/expected view
@@ -1,9 +1,8 @@ test002.idr:1:6:Universe inconsistency.-Working on: z-Old domain: Domain 6 6-New domain: Domain 6 5-Involved constraints: -	ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}-	ConstraintFC {uconstraint = y < z, ufc = test002.idr:1:6}-	ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}-+        Working on: z+        Old domain: (6,6)+        New domain: (6,5)+        Involved constraints: +                ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}+                ConstraintFC {uconstraint = y < z, ufc = test002.idr:1:6}+                ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}
test/error001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ test002.idr --check --noprelude+idris $@ test002.idr --check --noprelude --consolewidth 70 rm -f *.ibc
test/ffi001/expected view
@@ -1,2 +1,1 @@-Type checking ./test022.idr 0.9995736030415051
test/ffi003/expected view
@@ -1,2 +1,1 @@-Type checking ./test024.idr testtest
test/ffi006/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash idris $@ ffi006.idr --interface -o ffi006.o-cc ffi006.c ffi006.o `idris --include` `idris --link` -o ffi006+${CC:=cc} ffi006.c ffi006.o `idris --include` `idris --link` -o ffi006 ./ffi006 rm -f ffi006 *.ibc *.o *.h
+ test/folding001/expected view
@@ -0,0 +1,4 @@+([], []) -> ([], [])+([1], [1]) -> ([1], [1])+([1, 2, 3], [1, 2, 3]) -> ([1, 2, 3], [1, 2, 3])+([3, 2, 1], [3, 2, 1]) -> ([3, 2, 1], [3, 2, 1])
+ test/folding001/folding001.idr view
@@ -0,0 +1,25 @@+module Main++import Data.Vect++-- foldr (::) [] converts to lists+foldToList : (Foldable t) => t a -> List a+foldToList = foldr (::) [] ++showTestLine : List Int -> Vect n Int -> IO ()+showTestLine xs ys =+  putStrLn $ "(" ++ +    show xs ++ ", " ++ +    show ys ++ ") " ++ +    "-> (" ++ +    show (foldToList xs) ++ ", " ++ +    show (foldToList ys) ++ ")"++main : IO ()+main = do+  showTestLine [] []+  showTestLine [1] [1]+  showTestLine [1, 2, 3] [1, 2, 3]+  showTestLine [3, 2, 1] [3, 2, 1]++
+ test/folding001/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ folding001.idr -o folding001+./folding001+rm -f folding001 *.ibc
test/idrisdoc001/expected view
@@ -1,5 +1,3 @@-Type checking ./TestEmpty.idr-Type checking ./TestPrivate.idr Warning: Ignoring empty or non-existing namespace 'TestEmpty' Warning: Ignoring empty or non-existing namespace 'TestPrivate' No namespaces to generate documentation for
test/idrisdoc001/run view
test/idrisdoc001/test_empty.ipkg view
@@ -1,4 +1,6 @@ package test_empty +opts = "--quiet"+ modules = TestEmpty, TestPrivate 
test/idrisdoc002/expected view
@@ -1,2 +1,1 @@-Type checking ./TestFunctions.idr Functions are documented
test/idrisdoc002/test_functions.ipkg view
@@ -1,4 +1,6 @@ package test_functions +opts = "--quiet"+ modules = TestFunctions 
test/idrisdoc003/expected view
@@ -1,2 +1,1 @@-Type checking ./TestDatatypes.idr Data types are documented
test/idrisdoc003/test_datatypes.ipkg view
@@ -1,4 +1,6 @@ package test_datatypes +opts = "--quiet"+ modules = TestDatatypes 
test/idrisdoc004/expected view
@@ -1,2 +1,1 @@-Type checking ./TestTypeclasses.idr Typeclasses are documented
test/idrisdoc004/test_typeclasses.ipkg view
@@ -1,4 +1,6 @@ package test_typeclasses +opts = "--quiet"+ modules = TestTypeclasses 
test/idrisdoc005/expected view
@@ -1,3 +1,2 @@-Type checking ./TestTracing.idr TestTracing: Check Prelude.Bool: Check
test/idrisdoc005/test_tracing.ipkg view
@@ -1,4 +1,6 @@ package test_tracing +opts = "--quiet"+ modules = TestTracing 
test/idrisdoc006/expected view
@@ -1,6 +1,4 @@-Type checking ./A/fully/Qualified/NAME.idr IdrisDoc file written-Type checking ./B.idr A.fully.Qualified.NAME.html B.html A.fully.Qualified.NAME is in the index
test/idrisdoc006/package_a.ipkg view
@@ -1,4 +1,6 @@ package test_merge +opts = "--quiet"+ modules = A.fully.Qualified.NAME 
test/idrisdoc006/package_b.ipkg view
@@ -1,4 +1,6 @@ package test_merge +opts = "--quiet"+ modules = B 
test/idrisdoc007/package.ipkg view
@@ -1,4 +1,6 @@ package do_not_delete +opts = "--quiet"+ modules = A 
test/idrisdoc008/expected view
@@ -1,4 +1,2 @@-Type checking ./Abstract.idr-Type checking ./Visible.idr Abstract members are documented Public members are documented
test/idrisdoc008/visibility.ipkg view
@@ -1,4 +1,6 @@ package visibility +opts = "--quiet"+ modules = Abstract, Visible 
test/idrisdoc009/expected view
@@ -1,4 +1,3 @@-Type checking ./Test.idr Data type Test : Type     Docs for datatype Test.     
test/interactive001/expected view
@@ -1,4 +1,3 @@-Type checking ./test032.idr isElem x [] = ?isElem_rhs_1 isElem x (y :: xs) = ?isElem_rhs_3 
test/interactive002/expected view
@@ -1,4 +1,3 @@-Type checking ./interactive002.idr Nat Nat Nat
test/interactive003/expected view
@@ -1,4 +1,3 @@-Type checking ./interactive003.idr ys x :: app xs ys []
test/interactive004/expected view
@@ -1,3 +1,2 @@-Type checking ./interactive004.idr plus ?foo_rhs2 ?foo_rhs3 append k m ?append_rhs2 ?append_rhs3
test/interactive005/expected view
@@ -1,4 +1,3 @@-Type checking ./interactive005.idr 3 : Nat Hello, World main : IO ()
test/interactive006/expected view
@@ -1,2 +1,1 @@-Type checking ./interactive006.idr plus ?foo_rhs2 ?foo_rhs3
+ test/meta001/Finite.idr view
@@ -0,0 +1,184 @@+module Finite++import Data.Fin+import Language.Reflection.Elab+import Language.Reflection.Utils++-- Test various features of reflected elaboration, including looking+-- up datatypes, defining functions, and totality checking++%default total++||| A bijection between some type and bounded numbers+data Finite : Type -> Nat -> Type where+  IsFinite : (toFin : a -> Fin n) ->+             (fromFin : Fin n -> a) ->+             (ok1 : (x : a) -> fromFin (toFin x) = x) ->+             (ok2 : (y : Fin n) -> toFin (fromFin y) = y) ->+             Finite a n++acceptableConstructor : Raw -> Bool+acceptableConstructor (Var _) = True+acceptableConstructor _ = False++mkFin : Nat -> Nat -> Elab Raw+mkFin Z j = fail [TermPart `(Fin Z), TextPart "is uninhabitable!"]+mkFin (S k) Z = return `(FZ {k=~(quote k)})+mkFin (S k) (S j) = do i <- mkFin k j+                       return `(FS {k=~(quote k)} ~i)++mkToClause : TTName -> (size, i : Nat) -> (constr : (TTName, Raw)) -> Elab FunClause+mkToClause fn size i (n, Var ty) =+  MkFunClause (RApp (Var fn) (Var n)) <$> mkFin size i+mkToClause fn size i (n, ty) =+  fail [TextPart "unsupported constructor", NamePart n]+++mkFromClause : TTName -> (size, i : Nat) ->+               (constr : (TTName, Raw)) ->+               Elab FunClause+mkFromClause fn size i (n, Var ty) =+  return $ MkFunClause (RApp (Var fn) !(mkFin size i)) (Var n)+mkFromClause fn size i (n, ty) =+  fail [TextPart "unsupported constructor", NamePart n]+++mkOk1Clause : TTName -> (size, i : Nat) -> (constr : (TTName, Raw)) -> Elab FunClause+mkOk1Clause fn size i (n, Var ty) =+  return $ MkFunClause (RApp (Var fn) (Var n))+                       [| (Var (UN "Refl")) (Var ty) (Var n) |]+mkOk1Clause fn size i (n, ty) =+  fail [TextPart "unsupported constructor", NamePart n]+++mkOk2Clause : TTName -> (size, i : Nat) -> (constr : (TTName, Raw)) -> Elab FunClause+mkOk2Clause fn size i (n, Var ty) =+  return $ MkFunClause (RApp (Var fn) !(mkFin size i))+                       [| (Var "Refl") `(Fin ~(quote size))+                                       !(mkFin size i) |]+mkOk2Clause fn size i (n, ty) =+  fail [TextPart "unsupported constructor", NamePart n]+++mkToClauses : TTName -> Nat -> List (TTName, Raw) -> Elab (List FunClause)+mkToClauses fn size xs = mkToClauses' Z xs+  where mkToClauses' : Nat -> List (TTName, Raw) -> Elab (List FunClause)+        mkToClauses' k []        = return []+        mkToClauses' k (x :: xs) = do rest <- mkToClauses' (S k) xs+                                      clause <- mkToClause fn size k x+                                      return $ clause :: rest++||| Generate a clause for the end of a pattern-match on Fins that+||| declares its own impossibility.+|||+||| This is to satisfy the totality checker, because `impossible`+||| clauses are still+mkAbsurdFinClause : (fn : TTName) -> (goal : Raw -> Raw) -> (size : Nat) ->+                    Elab FunClause+mkAbsurdFinClause fn goal size =+  do pv <- gensym "badfin"+     lhsArg <- lhsBody pv size+     let lhs = RBind pv (PVar `(Fin Z : Type))+                     (RApp (Var fn) lhsArg)+     let rhs = RBind pv (PVar `(Fin Z : Type))+                     `(FinZElim {a=~(goal lhsArg)} ~(Var pv))+     return $ MkFunClause lhs rhs+  where lhsBody : TTName -> Nat -> Elab Raw+        lhsBody f Z = return $ Var f+        lhsBody f (S k) = do smaller <- lhsBody f k+                             return `(FS {k=~(quote k)} ~smaller)+++mkFromClauses : TTName -> TTName -> Nat ->+                List (TTName, Raw) -> Elab (List FunClause)+mkFromClauses fn ty size xs = mkFromClauses' Z xs+  where mkFromClauses' : Nat -> List (TTName, Raw) -> Elab (List FunClause)+        mkFromClauses' k []        =+             return [!(mkAbsurdFinClause fn (const (Var ty)) size)]+        mkFromClauses' k (x :: xs) = do rest <- mkFromClauses' (S k) xs+                                        clause <- mkFromClause fn size k x+                                        return $ clause :: rest++mkOk1Clauses : TTName -> Nat -> List (TTName, Raw) -> Elab (List FunClause)+mkOk1Clauses fn size xs = mkOk1Clauses' Z xs+  where mkOk1Clauses' : Nat -> List (TTName, Raw) -> Elab (List FunClause)+        mkOk1Clauses' k []        = return []+        mkOk1Clauses' k (x :: xs) = do rest <- mkOk1Clauses' (S k) xs+                                       clause <- mkOk1Clause fn size k x+                                       return $ clause :: rest++mkOk2Clauses : TTName -> Nat -> List (TTName, Raw) -> (Raw -> Raw) -> Elab (List FunClause)+mkOk2Clauses fn size xs resTy = mkOk2Clauses' Z xs+  where mkOk2Clauses' : Nat -> List (TTName, Raw) -> Elab (List FunClause)+        mkOk2Clauses' k []        = return [!(mkAbsurdFinClause fn resTy size)]+        mkOk2Clauses' k (x :: xs) = do rest <- mkOk2Clauses' (S k) xs+                                       clause <- mkOk2Clause fn size k x+                                       return $ clause :: rest+++genToFin : (to, from, ok1, ok2, ty : TTName) -> Elab ()+genToFin to from ok1 ok2 ty =+  do (MkDatatype famn tcargs tcres constrs) <- lookupDatatypeExact ty+     let size = length constrs+     argn <- gensym "arg"+     declareType $ Declare to [Explicit argn (Var ty)]+                           `(Fin ~(quote size))+     toClauses <- mkToClauses to size constrs+     defineFunction $ DefineFun to toClauses++     argn' <- gensym "arg"+     declareType $ Declare from [Explicit argn' `(Fin ~(quote size))]+                           (Var ty)+     fromClauses <- mkFromClauses from ty size constrs+     defineFunction $ DefineFun from fromClauses++     argn'' <- gensym "arg"+     declareType $ Declare ok1 [Explicit argn'' (Var ty)]+                           `((=) {A=~(Var ty)} {B=~(Var ty)}+                                 ~(RApp (Var from) (RApp (Var to) (Var argn'')))+                                 ~(Var argn''))+     ok1Clauses <- mkOk1Clauses ok1 size constrs+     defineFunction $ DefineFun ok1 ok1Clauses++     argn''' <- gensym "arg"+     let fty : Raw = `(Fin ~(quote size))+     let ok2ResTy = the (Raw -> Raw)+       (\n => `((=) {A=~fty} {B=~fty}+                   ~(RApp (Var to) (RApp (Var from) n))+                   ~n))+     declareType $ Declare ok2 [Explicit argn''' fty]+                           (ok2ResTy (Var argn'''))+     ok2Clauses <- mkOk2Clauses ok2 size constrs ok2ResTy+     defineFunction $ DefineFun ok2 ok2Clauses++     return ()+++deriveFinite : Elab ()+deriveFinite =+  do (App (App (P _ `{Finite} _) (P _ tyn _)) _) <- snd <$> getGoal+          | ty => fail [TextPart "inapplicable goal type", TermPart ty]+     (MkDatatype _ _ _ constrs) <- lookupDatatypeExact tyn+     let size = length constrs+     let to = SN (MetaN tyn (UN "toFinite"))+     let from = SN (MetaN tyn (UN "fromFinite"))+     let ok1 = SN (MetaN tyn (UN "finiteOk1"))+     let ok2 = SN (MetaN tyn (UN "finiteOk2"))+     genToFin to from ok1 ok2 tyn+     fill `(IsFinite {a=~(Var tyn)} {n=~(quote size)}+                     ~(Var to) ~(Var from)+                     ~(Var ok1) ~(Var ok2))+     solve++data TwoStateModel = Alive | Dead+data ThreeStateModel = Working | Disabled | Deceased+++twoStateFinite : Finite TwoStateModel 2+twoStateFinite = %runElab deriveFinite++threeStateFinite : Finite ThreeStateModel 3+threeStateFinite = %runElab deriveFinite++boolFinite : Finite Bool 2+boolFinite = %runElab deriveFinite
+ test/meta001/expected view
+ test/meta001/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --check --nocolour --consolewidth 70 Finite.idr+rm -f *.ibc
+ test/meta002/Tacs.idr view
@@ -0,0 +1,252 @@+||| A work-in-progress demonstration of Idris elaborator metaprogramming.+||| Goals:+|||  * Let tactics query the environment, for things like type signatures+|||  * Tactics expressions should be normal Idris expressions, and support+|||    things like idiom brackets, Alternative, etc+|||  * Make user-defined tactics just as easy to use as built-in ones+module Tacs++import Data.Fin+import Data.Vect++import Language.Reflection+import Language.Reflection.Errors+import Language.Reflection.Elab+import Language.Reflection.Utils++%default total++-- Tactics can now query the elaborator and bind variables++--stuff : Nat -> Nat -> Nat+--stuff x y = %runElab (debugMessage "oh noes")++intros : Elab ()+intros = do g <- getGoal+            case snd g of+              `(~_ -> ~_) => intro Nothing+              _ => return ()++foo : Nat -> Nat+foo = %runElab (do intro (Just (UN "fnord"))+                   fill `(plus ~(Var (UN "fnord")) ~(Var (UN "fnord")))+                   solve)+++++-- Note that <|> is equivalent to "try" in the old tactics.+-- In these tactics, we use ordinary do notation and ordinary documentation strings!+||| Try to solve a goal with simple guesses of easy type+triv : Elab ()+triv = do fill `(Z) <|> fill `(() : ())+          solve+++-- Solve both kinds of goal. The %runElab construction elaborates+-- to the result of running the tactic script that it contains.++test1 : ()+test1 = %runElab triv++test2 : Nat+test2 = %runElab triv+++namespace STLC++  data Ty = UNIT | ARR Ty Ty++  %name Ty t,t',t''++  instance Quotable Ty TT where+    quotedTy = `(Ty : Type)+    quote UNIT = `(UNIT : Ty)+    quote (ARR t t') = `(ARR ~(quote t) ~(quote t'))++  elabTy : Ty -> Elab ()+  elabTy UNIT = do fill `(() : Type)+                   solve+  elabTy (ARR t t') = do arg <- gensym "__stlc_arg"+                         n1 <- mkTypeHole "t1"+                         n2 <- mkTypeHole "t2"+                         fill (RBind arg (Pi (Var n1) RType) (Var n2))+                         focus n1; elabTy t+                         focus n2; elabTy t'+                         solve+    where mkTypeHole : String -> Elab TTName+          mkTypeHole hint = do holeName <- gensym hint+                               claim holeName RType+                               unfocus holeName+                               return holeName++  foo : %runElab (elabTy $ ARR (ARR UNIT UNIT) (ARR UNIT UNIT))+  foo = id++  namespace Untyped+    ||| Completely untyped terms+    data UTm = Lam String UTm | App UTm UTm | Var String | UnitCon+    %name UTm tm,tm',tm''++  namespace Scoped+    ||| Scope-checked terms - we'll use tactics to infer their types!+    data STm : Nat -> Type where+      Lam : String -> STm (S n) -> STm n+      App : STm n -> STm n -> STm n+      Var : Fin n -> STm n+      UnitCon : STm n+    %name STm tm,tm',tm''++    ||| Find the de Bruijn index for a variable in a naming context+    findVar : Eq a => a -> Vect n a -> Maybe (Fin n)+    findVar x [] = Nothing+    findVar x (y :: xs) = if x == y then pure FZ else [| FS (findVar x xs) |]++    ||| Resolve the names in a term to de Bruijn indices+    scopeCheck : Vect n String -> UTm -> Either String (STm n)+    scopeCheck vars (Lam x tm) = [| (Lam x) (scopeCheck (x::vars) tm) |]+    scopeCheck vars (App tm tm') = [| App (scopeCheck vars tm)+                                          (scopeCheck vars tm') |]+    scopeCheck vars (Var x) = case findVar x vars of+                                Nothing => Left $ "Unknown var " ++ x+                                Just i => pure $ Var i+    scopeCheck vars UnitCon = pure UnitCon++    forgetScope : Vect n String -> STm n -> UTm+    forgetScope vars (Lam x tm) = Lam x (forgetScope (x::vars) tm)+    forgetScope vars (App tm tm') = App (forgetScope vars tm)+                                        (forgetScope vars tm')+    forgetScope vars (Var i) = Var $ index i vars+    forgetScope vars UnitCon = UnitCon++  namespace Typed++    Env : Type+    Env = List Ty+    %name Typed.Env env++    ||| Well-typed de Bruijn indices+    data Ix : Env -> Ty -> Type where+      Z : Ix (t::env) t+      S : Ix env t -> Ix (t'::env) t+    %name Ix i,j,k++    data Tm : List Ty -> Ty -> Type where+      Lam : {env : List Ty} -> {t, t' : Ty} ->+            Tm (t::env) t' -> Tm env (ARR t t')+      App : Tm env (ARR t t') -> Tm env t -> Tm env t'+      Var : Ix env t -> Tm env t+      UnitCon : Tm env UNIT++  namespace Inference+    inNS : String -> TTName+    inNS n = NS (UN n) ["STLC", "Tacs"]++    inTypedNS : String -> TTName+    inTypedNS n = NS (UN n) ["Typed", "STLC", "Tacs"]++    elaborateSTLC : STm 0 -> Elab ()+    elaborateSTLC tm =+      do -- We're going to fill out a goal that wants a Sigma Ty (Tm [])+         -- First establish a hole for the type (inferred by side effect,+         -- similar to Idris implicit args)+         tH <- gensym "t"+         claim tH (Var (inNS "Ty"))+         unfocus tH+         -- Next we make a hole that wants a term in that type+         tmH <- gensym "tm"+         let p : Raw = `(Tm [])+         claim tmH (RApp p (Var tH))+         unfocus tmH++         -- Now we put this hole variable into our sigma constructor+         -- prior to elaboration, so it doesn't disappear too soon+         fill `(MkSigma ~(Var tH) ~(Var tmH) : Sigma Ty (Tm []))+         solve+         focus tmH+         mkTerm [] tm++        where mkEnvH : Elab TTName+              mkEnvH = do envH <- gensym "env"+                          claim envH `(List Ty)+                          unfocus envH+                          return envH++              mkTyH : Elab TTName+              mkTyH = do tyH <- gensym "ty"+                         claim tyH `(Ty)+                         unfocus tyH+                         return tyH++              mkIx : Fin n -> Elab ()+              mkIx FZ = do envH <- mkEnvH+                           tH <- mkTyH+                           apply `(Z {t=~(Var tH)} {env=~(Var envH)})+                           solve+              mkIx (FS i) = do envH <- mkEnvH+                               tH <- mkTyH+                               vH <- mkTyH+                               argH <- gensym "arg"+                               claim argH `(Ix ~(Var envH) ~(Var tH))+                               unfocus argH+                               apply `(S {env=~(Var envH)} {t=~(Var tH)} {t'=~(Var vH)} ~(Var argH))+                               solve+                               focus argH+                               mkIx i++              mkTerm : Vect n TTName -> STm n -> Elab ()+              mkTerm xs (Lam x tm) = do tH <- mkTyH+                                        envH <- mkEnvH+                                        tH' <- mkTyH+                                        bodyH <- gensym "body"+                                        claim bodyH `(Tm ((::) ~(Var tH) ~(Var envH)) ~(Var tH'))+                                        apply `(Lam {env=~(Var envH)}+                                                    {t=~(Var tH)} {t'=~(Var tH')}+                                                    ~(Var bodyH))++                                        solve+                                        focus bodyH+                                        mkTerm (tH::xs) tm+              mkTerm xs (App tm tm') = do envH <- mkEnvH+                                          tH <- mkTyH+                                          tH' <- mkTyH+                                          fH <- gensym "f"+                                          claim fH `(Tm ~(Var envH) (ARR ~(Var tH) ~(Var tH')))+                                          unfocus fH+                                          argH <- gensym "arg"+                                          claim argH `(Tm ~(Var envH) ~(Var tH))+                                          unfocus argH+                                          apply `(App {env=~(Var envH)}+                                                      {t=~(Var tH)} {t'=~(Var tH')}+                                                      ~(Var fH) ~(Var argH))+                                          solve+                                          focus fH+                                          mkTerm xs tm+                                          focus argH+                                          mkTerm xs tm'+              mkTerm xs (Var i) = do tH <- mkTyH+                                     envH <- mkEnvH+                                     ixH <- gensym "ix"+                                     claim ixH `(Ix ~(Var envH) ~(Var tH))+                                     unfocus ixH+                                     apply `(Var {env=~(Var envH)} {t=~(Var tH)} ~(Var ixH))+                                     solve+                                     focus ixH+                                     mkIx i+              mkTerm xs UnitCon = do envH <- mkEnvH+                                     apply `(UnitCon {env=~(Var envH)})+                                     solve+    testElab : Sigma Ty (Tm [])+    testElab = %runElab (elaborateSTLC (App (Lam "x" UnitCon) UnitCon))++    testElab2 : Sigma Ty (Tm [])+    testElab2 = %runElab (elaborateSTLC (App (Lam "x" (Var 0)) UnitCon))++    -- Doesn't work! :-)+    testElab3 : Sigma Ty (Tm [])+    testElab3 = %runElab (elaborateSTLC (App (Lam "x" (App (Var 0) (Var 0)))+                                             (Lam "x" (App (Var 0) (Var 0)))))+    -- Error is:+    -- Tacs.idr line 247 col 14:+    --     When elaborating right hand side of testElab3:+    --     Unifying ty and Tacs.STLC.ARR ty t would lead to infinite value
+ test/meta002/expected view
@@ -0,0 +1,3 @@+Tacs.idr:247:15:+When elaborating right hand side of testElab3:+Unifying ty and ARR ty t would lead to infinite value
+ test/meta002/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --nocolour --check --consolewidth 70 Tacs.idr+rm -f *.ibc
test/proof007/expected view
@@ -1,4 +1,4 @@ DefaultArgUnknownName.idr:9:6: When elaborating right hand side of test:-When elaborating argument [95marg[0m to function [92mDefaultArgUnknownName.funWithBadDefArg[0m:+When elaborating argument arg to function DefaultArgUnknownName.funWithBadDefArg:         No such variable sadgjhsag
test/proof007/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 --check $@ DefaultArgUnknownName.idr+idris --nocolour --consolewidth 80 --check $@ DefaultArgUnknownName.idr rm -f *.ibc
test/proof009/expected view
@@ -1,4 +1,3 @@-Type checking ./proof009.idr   ----------                 Goal:                  ----------
test/proof009/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --quiet proof009.idr < input+idris $@ --consolewidth 70 --quiet proof009.idr < input rm -f *.ibc
+ test/proof010/expected view
@@ -0,0 +1,6 @@+2, << function >>+3, << function >>++some bools+some bools+
+ test/proof010/proof010.idr view
@@ -0,0 +1,37 @@+data MyShow : Type -> Type where+     ShowInstance : (show : a -> String) -> MyShow a++myshow : {auto inst : MyShow a} -> a -> String+myshow {inst = ShowInstance show} x1 = show x1 ++%hint+showNat : MyShow Nat+showNat = ShowInstance show ++%hint+showFn : MyShow (a -> b)+showFn = ShowInstance (\x => "<< function >>")++%hint+showBools : MyShow (Bool, Bool)+showBools = ShowInstance (\x => "some bools")++%hint+showStuff : MyShow a -> MyShow b -> MyShow (a, b)+showStuff sa sb = ShowInstance showPair+  where+    showPair : (a, b) -> String+    showPair (x, y) = myshow x ++ ", " ++ myshow y++testShow : List (Bool, Bool) -> String+testShow [] = "" +testShow (x :: xs) = myshow x ++ "\n" ++ testShow xs++testShow2 : List (Nat, Int -> Int) -> String+testShow2 [] = "" +testShow2 (x :: xs) = myshow x ++ "\n" ++ testShow2 xs++main : IO ()+main = do putStrLn $ testShow2 [(2, (+1)), (3, abs)]+          putStrLn $ testShow [(True, False), (False, True)]+
+ test/proof010/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ proof010.idr -o proof010+./proof010+rm -f proof010 *.ibc
test/quasiquote004/Quasiquote004.idr view
@@ -5,7 +5,7 @@ %default total  normPlus : List (TTName, Binder TT) -> TT -> Tactic-normPlus ctxt `((=) {Nat} {Nat} ~x ~y) = normPlus ctxt x `Seq` normPlus ctxt y+normPlus ctxt `((=) {A = Nat} {B = Nat} ~x ~y) = normPlus ctxt x `Seq` normPlus ctxt y normPlus ctxt `(S ~n) = normPlus ctxt n normPlus ctxt `(plus ~n (S ~m)) = Seq (Rewrite `(plusSuccRightSucc ~n ~m))                                       (normPlus ctxt m)
+ test/quasiquote006/expected view
@@ -0,0 +1,13 @@+quasiquote006.idr:9:3:+When elaborating right hand side of b:+Can't disambiguate name: ForeignEnv.Nil, +                         Prelude.List.Nil+quasiquote006.idr:12:3:+When elaborating right hand side of c:+No such variable alsdkjflkj+quasiquote006.idr:15:3:+When elaborating right hand side of d:+Can't disambiguate name: ForeignEnv.::, +                         Prelude.List.::, +                         Prelude.Stream.::+quasiquote006.idr:17:3:Main.d already defined
+ test/quasiquote006/quasiquote006.idr view
@@ -0,0 +1,21 @@++a : TTName+a = `{Nat}++aOK : a = NS (UN "Nat") ["Nat", "Prelude"]+aOK = Refl++b : TTName+b = `{Nil}++c : TTName+c = `{alsdkjflkj}++d : TTName+d = `{(::)}++d : TTName+d = `{List.(::)}++dOK : d = NS (UN "::") ["List", "Prelude"]+dOK = Refl
+ test/quasiquote006/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --check --nocolour --quiet --consolewidth 70 quasiquote006.idr+rm -f *.ibc
test/records001/test011.idr view
@@ -2,14 +2,16 @@  import Data.Vect -record Foo : Nat -> Type where-    MkFoo : (name : String) ->-            (things : Vect n a) ->-            (more_things : Vect m b) ->-            Foo n--record Person : Type where-    MkPerson : (name : String) -> (age : Int) -> Person+record Foo (n : Nat) where+  constructor MkFoo+  name : String+  things : Vect n a+  more_things : Vect m b+  +record Person where+  constructor MkPerson+  name : String+  age : Int  testFoo : Foo 3 testFoo = MkFoo "name" [1,2,3] [4,5,6,7]
test/records002/record002.idr view
@@ -1,11 +1,12 @@--record Foo : Nat -> Type where-       MkFoo : (param : Nat) -> (num : Int) -> Foo param+record Foo (param : Nat) where+  constructor MkFoo+  num : Int  instance Show (Foo n) where-  show f = show (param f) ++ ", " ++ show (num f)+  show f = show (param_param f) ++ ", " ++ show (num f)  main : IO ()-main = do let x = MkFoo 10 20-          putStrLn (show (record { param = 42 } x))+main = do let x = MkFoo {param=10} 20+          putStrLn (show (record { param_param = 42 } x))           putStrLn (show (record { num = 42 } x))+
test/records003/records003.idr view
@@ -1,47 +1,46 @@-record Person : Nat -> Type where-       MkPerson : (name : String) ->-                  (age : Nat) ->-                  Person age+record Person (age : Nat) where+  constructor MkPerson+  name : String -record Event : Type where-       MkEvent : (name : String) -> (organiser : Person a) -> Event +record Event where+  constructor MkEvent+  name : String+  organiser : Person a -record Meeting : Int -> Type where-       MkMeeting : (event : Event) -> -                   (organiser : Person a) -> -                   (year : Int) -> -                   Meeting year+record Meeting (year : Int) where+  constructor MkMeeting+  event : Event+  organiser : Person a  new_organiser : String -> List (Meeting x) -> List (Meeting x) new_organiser n = map (record { event->organiser->name = n })   next_year : Meeting x -> Meeting (x+1)-next_year m = record { organiser->age-                          = record { organiser->age } m + 1,-                       event->organiser->age-                          = record { event->organiser->age } m + 1,-                       year = _ } m+next_year m = record { organiser->param_age+                          = record { organiser->param_age } m + 1,+                       event->organiser->param_age+                          = record { event->organiser->param_age } m + 1,+                       param_year = _ } m  fred : Person 20-fred = MkPerson "Fred" _+fred = MkPerson "Fred"  jim : Person 29-jim = MkPerson "Jim" 29+jim = MkPerson {age=29} "Jim"  idm : Event idm = MkEvent "Idris Developers Meeting" fred  idm_gbg : Meeting 2014-idm_gbg = MkMeeting idm jim _+idm_gbg = MkMeeting idm jim  test : Meeting 2015 test = next_year idm_gbg  main : IO () main = do printLn (record { event->organiser->name } test)-          printLn (record { event->organiser->age } test)-          printLn (record { event->organiser->age } idm_gbg)-          printLn (record { organiser->age } test)-          printLn (record { organiser->age } idm_gbg)-          printLn (record { year } idm_gbg)-+          printLn (record { event->organiser->param_age } test)+          printLn (record { event->organiser->param_age } idm_gbg)+          printLn (record { organiser->param_age } test)+          printLn (record { organiser->param_age } idm_gbg)+          printLn (record { param_year } idm_gbg)
test/reg003/expected view
@@ -1,2 +1,6 @@ reg003a.idr:4:11:When elaborating type of Main.ECons: No such variable OddList+reg003a.idr:7:11:When elaborating type of Main.OCons:+No such variable EvenList+reg003a.idr:9:6:When elaborating type of Main.test:+No such variable EvenList
test/reg007/expected view
@@ -1,5 +1,5 @@ reg007.lidr:8:1:A.n is already defined-reg007.lidr:12:11:When elaborating right hand side of hurrah:+reg007.lidr:12:11-17:When elaborating right hand side of hurrah: Can't unify         n = lala (Type of isSame) with
test/reg012/reg012.lidr view
@@ -32,5 +32,5 @@ > modifyFunLemma f (a,b) = >   rewrite soTrue (reflexive_eqeq a) in Refl -   replace {P = \ z => boolElim (a == a) b (f a) = boolElim z b (f a)}+   replace {P = \ z => ifThenElse (a == a) b (f a) = ifThenElse z b (f a)}            (soTrue (reflexive_eqeq a)) Refl
test/reg023/expected view
@@ -1,5 +1,5 @@ reg023.idr:7:5:When elaborating right hand side of bad: Can't unify-        [94mNat[0m (Type of [91m0[0m)+        Nat (Type of 0) with-        [92mf[0m [94mNat[0m (Expected type)+        f Nat (Expected type)
test/reg023/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ reg023.idr --check+idris --nocolour --consolewidth 80 $@ reg023.idr --check rm -f *.ibc
test/reg029/reg029.idr view
@@ -3,7 +3,7 @@ import System  -- necessary to find the getenv symbol-%dynamic "libm"+%dynamic "libm","msvcrt"  main : IO () main = do
test/reg034/expected view
@@ -1,4 +1,4 @@ reg034.idr:6:5:When elaborating left hand side of bar:-Can't match on bar xs xs [91mRefl[0m+Can't match on bar xs xs Refl reg034.idr:9:5:When elaborating left hand side of foo:-Can't match on foo f x x [91mRefl[0m+Can't match on foo f x x Refl
test/reg034/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 --check reg034.idr+idris --nocolour --consolewidth 80 --check reg034.idr rm -f reg034 *.ibc
test/reg035/expected view
@@ -1,4 +1,1 @@-reg035b.idr:8:6:Can't convert-        [94mAdditive[0m -> [94mNat[0m-with-        [94mFin[0m [91m0[0m+reg035b.idr:8:6:No such variable __pi_arg
test/reg035/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris --consolewidth 80 --check reg035.idr-idris --consolewidth 80 --check reg035a.lidr-idris --consolewidth 80 --check reg035b.idr+idris --nocolour --consolewidth 80 --check reg035.idr+idris --nocolour --consolewidth 80 --check reg035a.lidr+idris --nocolour --consolewidth 80 --check reg035b.idr rm -f *.ibc
test/reg037/reg037.idr view
@@ -1,9 +1,9 @@  --- Parser regression for (=) as a function name (fnName) -class Foo (t : (A : Type) -> (B : Type) -> A -> B -> Type) where-  foo : (A : Type) -> (B : Type) -> (x : A) -> (y : B) -> t A B x y -> t A B x y+class Foo (t : a -> b -> Type) where+  foo : (x : _) -> (y : _) -> t x y -> t x y -instance Foo (=) where-  foo A B x y prf = prf+instance Foo ((=) {A=a} {B=b}) where+  foo x y prf = prf 
test/reg039/expected view
@@ -1,2 +1,1 @@-Type checking ./reg039.idr [3, 2, 1]
test/reg039/run view
@@ -1,32 +1,35 @@ #!/usr/bin/env bash -# From http://unix.stackexchange.com/questions/43340/how-to-introduce-timeout-for-shell-scripting-# Executes command with a timeout-# Params:-#   $1 timeout in seconds-#   $2 command-# Returns 1 if timed out 0 otherwise-timeout() { -    time=$1--    # start the command in a subshell to avoid problem with pipes-    # (spawn accepts one command)-    command="/bin/sh -c \"$2\""--    expect -c "set echo \"-noecho\"; set timeout $time; spawn -noecho $command; expect timeout { exit 1 } eof { exit 0 }"--    if [ $? = 1 ] ; then-        echo "Timeout after ${time} seconds"-    fi--}- declare -a extraargs for arg in "$@" do     extraargs=("${extraargs[@]}" "'$arg'") done+if (which timeout&>/dev/null); then+   timeout 60 idris $@ --nocolour reg039.idr --exec go+else+    # From http://unix.stackexchange.com/questions/43340/how-to-introduce-timeout-for-shell-scripting+    # Executes command with a timeout+    # Params:+    #   $1 timeout in seconds+    #   $2 command+    # Returns 1 if timed out 0 otherwise+    timeout() { -timeout 60 "idris ${extraargs[*]} --nocolour reg039.idr --exec go"-rm -f reg039 *.ibc+        time=$1++        # start the command in a subshell to avoid problem with pipes+        # (spawn accepts one command)+        command="/bin/sh -c \"$2\""++        expect -c "set echo \"-noecho\"; set timeout $time; spawn -noecho $command; expect timeout { exit 1 } eof { exit 0 }"++        if [ $? = 1 ] ; then+            echo "Timeout after ${time} seconds"+        fi++    }+    timeout 60 "idris ${extraargs[*]} --nocolour reg039.idr --exec go"+    fi+    rm -f reg039 *.ibc
test/reg041/expected view
@@ -1,3 +1,2 @@-Type checking ./ott.idr ?prf : (x : Bool) -> (x1 : Bool) -> El (EQ two x two x1) -> El (EQ two x two x1) Z
test/reg044/expected view
@@ -1,11 +1,11 @@ reg044.idr:4:4:When elaborating right hand side of Main.pf: Can't unify-        [95mb[0m [94m=[0m [95mb[0m (Type of [91mRefl[0m)+        b = b (Type of Refl) with-        [95ma[0m [94m=[0m [95mb[0m (Expected type)+        a = b (Expected type)  Specifically:         Can't unify-                [95mb[0m+                b         with-                [95ma[0m+                a
test/reg044/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 reg044.idr --check+idris --nocolour --consolewidth 80 reg044.idr --check rm -f *.ibc
test/reg047/reg047.idr view
@@ -6,10 +6,10 @@ data Nat = zero | succ Nat  Id : (A : Type) -> A -> A -> Type-Id A = (=) {a0 = A} {b0 = A}+Id A = (=) {A = A} {B = A}  IdRefl : (A : Type) -> (a : A) -> Id A a a-IdRefl A a = Refl {a}+IdRefl A a = Refl {x = a}  zzz : Id Nat zero zero zzz = IdRefl Nat zero
test/reg047/reg047a.idr view
@@ -9,7 +9,7 @@ Id = \A,x,y => x = y --  {a = A} {b = A}  IdRefl : (A : Type) -> (a : A) -> Id A a a-IdRefl A a = Refl {a}+IdRefl A a = Refl {x = a}  zzzz : Id MNat zero zero zzzz = IdRefl MNat zero
test/reg049/expected view
@@ -1,2 +1,4 @@ reg049.idr:2:9:When elaborating constructor Main.Bogus: Void is not Main.Foo+reg049.idr:5:6:When elaborating right hand side of uhOh:+No such variable Bogus
test/reg054/expected view
@@ -1,10 +1,12 @@ reg054.idr:18:5:When elaborating left hand side of inf:-When elaborating an application of constructor [91mMain.MkInfer[0m:+When elaborating an application of constructor Main.MkInfer:         Attempting concrete match on polymorphic argument: 0 reg054.idr:34:7:When elaborating left hand side of weird:-When elaborating argument [95mx[0m to Main.weird:+When elaborating argument x to Main.weird:         No explicit types on left hand side: Char-reg054.idr:37:9:Can't convert-        [94mMaybe[0m a1-with-        [95ma[0m+reg054.idr:37:1-8:When elaborating left hand side of tctrick:+When elaborating an application of Main.tctrick:+        Can't unify+                Maybe a1 (Type of Just x)+        with+                a (Expected type)
test/reg054/run view
@@ -1,2 +1,2 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ reg054.idr --check+idris --nocolour --consolewidth 80 $@ reg054.idr --check
test/reg055/expected view
@@ -1,9 +1,9 @@ reg055.idr:5:3:When elaborating left hand side of g:-Can't match on g ([92mf[0m [91m0[0m)+Can't match on g (f 0) reg055.idr:8:3:When elaborating left hand side of h: Can't match on h x x reg055a.idr:8:5:When elaborating left hand side of foo:-When elaborating an application of constructor [91mFoo.CAny[0m:+When elaborating an application of constructor Foo.CAny:         Attempting concrete match on polymorphic argument: Nothing reg055a.idr:13:7:When elaborating left hand side of Foo.apply:-Can't match on apply (\[95mx[0m => \[95my[0m => [95mx[0m) a+Can't match on apply (\x => \y => x) a
test/reg055/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ reg055.idr --check-idris --consolewidth 80 $@ reg055a.idr --check+idris --nocolour --consolewidth 80 $@ reg055.idr --check+idris --nocolour --consolewidth 80 $@ reg055a.idr --check rm -f *.ibc 
test/reg056/reg056.idr view
@@ -6,7 +6,7 @@ dodgy : (a, b : ()) -> a = b -> Void dodgy n m Refl impossible -nonk : (trap = Refl {Z}) -> Void+nonk : (trap = Refl {x = Z}) -> Void nonk Refl impossible  false : Void
+ test/reg062/expected view
+ test/reg062/reg062.idr view
@@ -0,0 +1,13 @@+module MinCrash++-- Test that #2130 stays fixed. It's important that the first argument+-- to revInduction be called `pred` here, because the bug was+-- triggered by looking up a bound variable in the global context and+-- getting an ambiguous result in a context where fully-qualified+-- names were expected.++revInduction : (P : List a -> Type) -> P [] -> ((xs : List a) -> (x : a) -> P xs -> P (xs ++ [x]))+               -> (ys : List a) -> P ys+revInduction pred base ind ys with (reverse ys)+  revInduction pred base ind _ | revys =+    ?revInduction_rhs
+ test/reg062/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ reg062.idr --check --nocolour+idris $@ reg062.lidr --check --nocolour+rm -f *.ibc
+ test/reg063/Cmp.idr view
@@ -0,0 +1,19 @@+||| Test that explicit proof objects on the with rule work+module Cmp+++data MyCmp : Nat -> Nat -> Type where+  IsLT : (d : Nat) -> MyCmp n         (S d + n)+  IsEQ :              MyCmp n         n+  IsGT : (d : Nat) -> MyCmp (S d + n) n++myCmp : (j, k : Nat) -> MyCmp j k+myCmp Z     Z     = IsEQ+myCmp Z     (S k) = rewrite sym $ plusZeroRightNeutral k in IsLT k+myCmp (S j) Z     = rewrite sym $ plusZeroRightNeutral j in IsGT j+myCmp (S j) (S k) with (myCmp j k) proof p+  myCmp (S j) (S (S (plus d j))) | (IsLT d) = rewrite plusSuccRightSucc d j+                                              in let useless = id p in IsLT d+  myCmp (S j)              (S j) | IsEQ = IsEQ+  myCmp (S (S (plus d k))) (S k) | (IsGT d) = rewrite plusSuccRightSucc d k+                                              in IsGT d
+ test/reg063/expected view
+ test/reg063/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ Cmp.idr --check --nocolour --quiet+rm *.ibc
+ test/reg064/expected view
+ test/reg064/reg064.idr view
@@ -0,0 +1,9 @@+sigmaEq2 : {A : Type} -> +           {P : A -> Type} -> +           {s1: Sigma A P} -> +           {s2: Sigma A P} ->+           getWitness s1 = getWitness s2 ->+           getProof s1 = getProof s2 ->+           s1 = s2+sigmaEq2 {A} {P} {s1 = (x ** prf)} {s2 = (x ** prf)} Refl Refl = Refl+
+ test/reg064/reg064a.idr view
@@ -0,0 +1,89 @@+import Data.Vect+import Data.Fin+import Control.Isomorphism++Dec0 : Type -> Type+Dec0 = Dec++Dec1 : {A : Type} -> (P : A -> Type) -> Type+Dec1 {A} P = (a : A) -> Dec0 (P a) ++Unique : Type -> Type+Unique t = (p : t) -> (q : t) -> p = q++Unique0 : Type -> Type+Unique0 = Unique++Unique1 : (t0 -> Type) -> Type+Unique1 {t0} t1 = (v : t0) -> Unique0 (t1 v)++namespace Iso++  from : {A, B : Type} -> Iso A B -> (B -> A)+  from (MkIso to from toFrom fromTo) = from++namespace Fin++  ||| 'Tail' of a finite function+  tail : {A : Type} -> {n : Nat} ->+         (Fin (S n) -> A) -> (Fin n -> A)+  tail f k = f (FS k)++  ||| Maps a finite function to a vector+  toVect : {A : Type} -> {n : Nat} ->+           (Fin n -> A) -> Vect n A+  toVect {n =   Z} _ = Nil+  toVect {n = S m} f = (f FZ) :: (toVect (tail f))++namespace Finite++  ||| Notion of finiteness for types+  Finite : Type -> Type+  Finite A = Exists (\ n => Iso A (Fin n))++  ||| Cardinality of finite types+  card : {A : Type} -> (fA : Finite A) -> Nat+  card = getWitness++  ||| Maps a finite type |A| of cardinality |n| to a vector of |A|-values of length |n|+  toVect : {A : Type} -> (fA : Finite A) -> Vect (card fA) A+  toVect (Evidence n iso) = toVect (from iso)++||| Filters a vector on a decidable property and pairs elements with proofs+filterTag : {A : Type} ->+            {P : A -> Type} ->+            Dec1 P ->+            Vect n A -> +            Sigma Nat (\ m => Vect m (Sigma A P))+filterTag d1P Nil = (_ ** Nil)+filterTag d1P (a :: as) with (filterTag d1P as)+  | (_ ** tail) with (d1P a)+    | (Yes p) = (_ ** (a ** p) :: tail)+    | (No  _) = (_ ** tail)++||| Maps a finite type |A| and a decidable predicate |P| to a vector |Sigma A P| values+toVect : {A : Type} ->+         {P : A -> Type} ->+         Finite A ->+         Dec1 P ->+         (n : Nat ** Vect n (Sigma A P))+toVect fA d1P = filterTag d1P (toVect fA)++sigmaUniqueLemma1 : {A   : Type} ->+                    {P   : A -> Type} ->+                    Unique1 {t0 = A} P ->+                    (a : A) ->+                    (p : P a) ->+                    (ss : Vect n (Sigma A P)) ->+                    Elem a (map getWitness ss) -> +                    Elem (a ** p) ss++toVectComplete : {A   : Type} ->+                 {P   : A -> Type} ->+                 (fA  : Finite A) -> +                 (d1P : Dec1 P) -> +                 Unique1 {t0 = A} P ->+                 (s   : Sigma A P) -> +                 Elem s (getProof (toVect fA d1P))++
+ test/reg064/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ reg064.idr --check+idris $@ reg064a.idr --check+rm -f *.ibc
test/runtest.pl view
@@ -10,10 +10,11 @@  sub sandbox_path {     my ($test_dir,) = @_;-    my $sandbox = abs_path("$test_dir/../../.cabal-sandbox/bin");+    my $sandbox = "$test_dir/../../.cabal-sandbox/bin";      if ( -d $sandbox ) {-        return "PATH=$sandbox:$PATH";+        my $sandbox_abs = abs_path($sandbox);+        return "PATH=\"$sandbox_abs:$PATH\"";     } else {         return "";     }@@ -30,6 +31,14 @@     my $got = `$sandbox ./run @idrOpts`;     my $exp = `cat expected`; +    # Allow for variant expected output for tests by overriding expected+    # when there is an expected.<os> file in the test.+    # This should be the exception but there are sometimes valid reasons+    # for os-dependent output.+    # The endings are msys for windows, darwin for osx and linux for linux+    if ( -e "expected.$^O") {+        $exp = `cat expected.$^O`;+    }     open my $out, '>', 'output';     print $out $got;     close $out;
test/sourceLocation001/expected view
@@ -1,11 +1,11 @@ Testing using definition-FileLoc "SourceLoc.idr" (16, 11) (16, 11)+FileLoc "SourceLoc.idr" (16, 11) (16, 17) Testing using inline tactics FileLoc "SourceLoc.idr" (20, 17) (20, 17) Testing using metavariable with later definition FileLoc "SourceLoc.idr" (98, 16) (98, 16) ----------------------- Success!-Error at FileLoc "SourceLoc.idr" (72, 23) (72, 23)+Error at FileLoc "SourceLoc.idr" (72, 23) (72, 26) Success! Success!
test/tactics001/Tactics.idr view
@@ -1,6 +1,6 @@ module Tactics -import Language.Reflection.Tactical+import Language.Reflection.Elab  import Data.Vect @@ -18,24 +18,24 @@ plusZeroRightNeutralNew : (n : Nat) -> plus n 0 = n plusZeroRightNeutralNew Z = Refl plusZeroRightNeutralNew (S k) =-  %runTactics (do rewriteWith `(sym $ plusZeroRightNeutralNew ~(Var "k"))-                  fill $ refl `(Nat : Type) `(S ~(Var (UN "k")))-                  solve)+  %runElab (do rewriteWith `(sym $ plusZeroRightNeutralNew ~(Var "k"))+               fill $ refl `(Nat : Type) `(S ~(Var (UN "k")))+               solve)  plusSuccRightSuccNew : (j, k : Nat) -> plus j (S k) = S (plus j k) plusSuccRightSuccNew Z k = Refl plusSuccRightSuccNew (S j) k =-  %runTactics (do rewriteWith `(sym $ plusSuccRightSuccNew ~(Var "j") ~(Var (UN "k")))-                  fill $ refl `(Nat : Type) `(S (S (plus ~(Var (UN "j")) ~(Var (UN "k")))))-                  solve)+  %runElab (do rewriteWith `(sym $ plusSuccRightSuccNew ~(Var "j") ~(Var (UN "k")))+               fill $ refl `(Nat : Type) `(S (S (plus ~(Var (UN "j")) ~(Var (UN "k")))))+               solve)  -- Test that side effects in new tactics work  mkDecl : ()-mkDecl = %runTactics (do declareType $ Declare (NS (UN "repUnit") ["Tactics"])+mkDecl = %runElab (do declareType $ Declare (NS (UN "repUnit") ["Tactics"])                                                [Implicit (UN "z") `(Nat)]                                                `(Vect ~(Var (UN "z")) ())-                         fill `(() : ())-                         solve)+                      fill `(() : ())+                      solve)  repUnit = pure ()
test/totality002/test017.idr view
@@ -93,8 +93,8 @@  maxCommutativeStepCase = proof {     intros;-    rewrite (boolElimSuccSucc (lte left right) right left);-    rewrite (boolElimSuccSucc (lte right left) left right);+    rewrite (ifThenElseSuccSucc (lte left right) right left);+    rewrite (ifThenElseSuccSucc (lte right left) left right);     rewrite inductiveHypothesis;     trivial; }
test/totality006/totality006b.idr view
@@ -7,8 +7,8 @@ -- case but not on test006.idr, due to the extra computation. total blargh : (xs, ys : List a) -> So (length xs > length ys) -> GT (length xs) (length ys)-blargh [] [] Oh impossible blargh [] (y :: xs) so = absurd so blargh (y :: xs) [] Oh = LTESucc LTEZero --- Missing: blargh (y :: xs) (z :: ys) x = ?blargh_rhs_3+-- Missing: blargh (y :: xs) (z :: ys) p = ?blargh_rhs_3+-- blargh [] [] p = ?foo -- impossible
test/totality007/expected view
@@ -1,4 +1,3 @@-Type checking ./Totality.idr Totality.idr:4:1: Totality.foo is not total as there are missing cases Totality.idr:4:1:Could not build: Totality.foo is not total as there are missing cases
test/totality007/totality.ipkg view
@@ -2,6 +2,6 @@  -- totality007 -- Test that the package builder doesn't allow totality errors in a build-opts = "--consolewidth 80"+opts = "--quiet --consolewidth 80" sourcedir = src modules = Totality
+ test/totality009/TestLambdaImpossible.idr view
@@ -0,0 +1,26 @@+module TestLambdaImpossible++%default total++eqBool : (x, y : Bool) -> Dec (x = y)+eqBool False False = Yes Refl+eqBool False True = No (\(Refl) impossible)+eqBool True False = No (\(Refl) impossible)+eqBool True True = Yes Refl++data Elem : {a : Type} -> a -> Prelude.List.List a -> Type where+  Here : {a : Type} -> {x : a} -> {xs : List a} -> Elem x (x :: xs)+  There : {a : Type} -> {x, y : a} -> {xs : List a} -> Elem x xs -> Elem x (y :: xs)++notHereNotThere : Not (x = y) -> Not (Elem x xs) -> Not (Elem x (y :: xs))+notHereNotThere notEq notElem Here = notEq Refl+notHereNotThere notEq notElem (There elem) = notElem elem++decElem : DecEq a => (x : a) -> (xs : List a) -> Dec (Elem x xs)+decElem x [] = No (\Here impossible)+decElem x (y :: xs) with (decEq x y)+  decElem x (x :: xs) | (Yes Refl) = Yes Here+  decElem x (y :: xs) | (No notHere) with (decElem x xs)+    decElem x (y :: xs) | (No notHere) | (Yes prf) = Yes (There prf)+    decElem x (y :: xs) | (No notHere) | (No notThere) = No $ notHereNotThere notHere notThere+
+ test/totality009/TestLambdaPossible.idr view
@@ -0,0 +1,13 @@+||| Some functions that should be non-total, as detected with --warnpartial+module TestLambdaPossible++data Nool : Bool -> Type where+  Flase : Nool False+  Ture : Nool True++wrongPossible : Nool True -> Bool+wrongPossible = (\Flase impossible)++wrongPossible' : Nool True -> Bool+wrongPossible' x = case x of+                        Flase impossible
+ test/totality009/expected view
@@ -0,0 +1,8 @@+TestLambdaPossible.idr:9:25:Warning - TestLambdaPossible.case block in wrongPossible is not total as there are missing cases+TestLambdaPossible.idr:9:1:Warning - TestLambdaPossible.wrongPossible is possibly not total due to: TestLambdaPossible.case block in wrongPossible+TestLambdaPossible.idr:12:25:Warning - TestLambdaPossible.case block in wrongPossible' is not total as there are missing cases+TestLambdaPossible.idr:12:1:Warning - TestLambdaPossible.wrongPossible' is possibly not total due to: TestLambdaPossible.case block in wrongPossible'+TestLambdaPossible.idr:9:15:Warning - TestLambdaPossible.case block in wrongPossible is not total as there are missing cases+TestLambdaPossible.idr:9:1:Warning - TestLambdaPossible.wrongPossible is possibly not total due to: TestLambdaPossible.case block in wrongPossible+TestLambdaPossible.idr:12:16:Warning - TestLambdaPossible.case block in wrongPossible' is not total as there are missing cases+TestLambdaPossible.idr:12:1:Warning - TestLambdaPossible.wrongPossible' is possibly not total due to: TestLambdaPossible.case block in wrongPossible'
+ test/totality009/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+OPTS="--consolewidth infinite --nocolour"+idris "$@" $OPTS --check TestLambdaImpossible+idris "$@" $OPTS --check --warnpartial TestLambdaPossible+rm -f *.ibc
test/tutorial006/expected view
@@ -1,24 +1,25 @@-tutorial006a.idr:5:23:When elaborating right hand side of vapp:-When elaborating argument [95mxs[0m to constructor [91mData.VectType.Vect.::[0m:+tutorial006a.idr:5:23-25:+When elaborating right hand side of vapp:+When elaborating argument xs to constructor Data.VectType.Vect.:::         Can't unify-                [94mVect[0m ([95mn[0m [92m+[0m [95mn[0m) [95ma[0m (Type of vapp [95mxs[0m [95mxs[0m)+                Vect (n + n) a (Type of vapp xs xs)         with-                [94mVect[0m ([92mplus[0m [95mn[0m [95mm[0m) [95ma[0m (Expected type)+                Vect (plus n m) a (Expected type)                  Specifically:                 Can't unify-                        [92mplus[0m [95mn[0m [95mn[0m+                        plus n n                 with-                        [92mplus[0m [95mn[0m [95mm[0m+                        plus n m tutorial006b.idr:10:10: When elaborating right hand side of with block in Main.parity: Can't unify-        [94mParity[0m ([92mplus[0m ([91mS[0m [95mj[0m) ([91mS[0m [95mj[0m)) (Type of [91meven[0m)+        Parity (plus (S j) (S j)) (Type of even) with-        [94mParity[0m ([91mS[0m ([91mS[0m ([92mplus[0m [95mj[0m [95mj[0m))) (Expected type)+        Parity (S (S (plus j j))) (Expected type)  Specifically:         Can't unify-                [92mplus[0m ([91mS[0m [95mj[0m) ([91mS[0m [95mj[0m)+                plus (S j) (S j)         with-                [91mS[0m ([91mS[0m ([92mplus[0m [95mj[0m [95mj[0m))+                S (S (plus j j))
test/tutorial006/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ tutorial006a.idr --check-idris --consolewidth 80 $@ tutorial006b.idr --check+idris --nocolour --consolewidth 80 $@ tutorial006a.idr --check+idris --nocolour --consolewidth 80 $@ tutorial006b.idr --check rm -f *.ibc
test/unique001/expected view
@@ -3,17 +3,17 @@ 38,36,34,32,30,28,26,24,22,20,18,16,14,12,10,8,6,4,2,0,END 38,36,34,32,30,28,26,24,22,20,18,16,14,12,10,8,6,4,2,0,END unique001a.idr:33:11:Can't convert-        [94mInt[0m -> [94mString[0m+        Int -> String with-        UniqueType ([94mInt[0m -> [94mString[0m)+        UniqueType (Int -> String) unique001a.idr:44:12:Can't convert-        [94mInt[0m -> [94mString[0m+        Int -> String with-        UniqueType ([94mInt[0m -> [94mString[0m)+        UniqueType (Int -> String) unique001a.idr:55:12:Can't convert-        UniqueType ([94mInt[0m -> [94mString[0m)+        UniqueType (Int -> String) with-        [94mInt[0m -> [94mString[0m+        Int -> String unique001b.idr:16:7:Borrowed name xs must not be used on RHS unique001c.idr:46:6:Unique name f is used more than once unique001d.idr:3:7:Borrowed name x must not be used on RHS
test/unique001/run view
@@ -1,9 +1,9 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ unique001.idr -o unique001+idris --nocolour --consolewidth 80 $@ unique001.idr -o unique001 ./unique001-idris --consolewidth 80 $@ unique001a.idr --check-idris --consolewidth 80 $@ unique001b.idr --check-idris --consolewidth 80 $@ unique001c.idr --check-idris --consolewidth 80 $@ unique001d.idr --check-idris --consolewidth 80 $@ unique001e.idr --check+idris --nocolour --consolewidth 80 $@ unique001a.idr --check+idris --nocolour --consolewidth 80 $@ unique001b.idr --check+idris --nocolour --consolewidth 80 $@ unique001c.idr --check+idris --nocolour --consolewidth 80 $@ unique001d.idr --check+idris --nocolour --consolewidth 80 $@ unique001e.idr --check rm -f unique001 *.ibc
test/unique001/unique001c.idr view
@@ -25,7 +25,7 @@ share ULeaf = Leaf share (UNode x y z) = Node (share x) y (share z) -class UFunctor (f : Type -> Type*) where+class UFunctor (f : Type -> AnyType) where     fmap : (a -> b) -> f a -> f b  instance UFunctor List where@@ -36,10 +36,10 @@     fmap f UNil = UNil     fmap f (UCons x xs) = UCons (f x) (fmap f xs) -uconst : {a : Type*} -> a -> b -> a+uconst : {a : AnyType} -> a -> b -> a uconst x y = x -data MPair : Type* -> Type* -> Type* where+data MPair : AnyType -> AnyType -> AnyType where      MkMPair : {a, b : Type*} -> a -> b -> MPair a b  ndup : {a : UniqueType} -> a -> UPair a a
test/unique002/expected view
@@ -1,5 +1,5 @@ unique002.idr:15:5:Unique name xs is used more than once unique002a.idr:15:5:Can't convert-        [94mInt[0m -> [94mString[0m+        Int -> String with-        UniqueType ([94mInt[0m -> [94mString[0m)+        UniqueType (Int -> String)
test/unique002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ unique002.idr --check-idris --consolewidth 80 $@ unique002a.idr --check+idris --nocolour --consolewidth 80 $@ unique002.idr --check+idris --nocolour --consolewidth 80 $@ unique002a.idr --check rm -f *.ibc
test/unique003/expected view
@@ -1,4 +1,4 @@ unique003.idr:18:5:Can't convert-        [94mInt[0m -> [94mString[0m+        Int -> String with-        UniqueType ([94mInt[0m -> [94mString[0m)+        UniqueType (Int -> String)
test/unique003/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ unique003.idr --check+idris --nocolour --consolewidth 80 $@ unique003.idr --check rm -f *.ibc