idris 0.9.16 → 0.9.17
raw patch · 331 files changed
+8542/−5145 lines, 331 filesdep +safedep +transformers-compatdep ~blaze-markupdep ~mtlsetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: safe, transformers-compat
Dependency ranges changed: blaze-markup, mtl
API changes (from Hackage documentation)
- IRTS.Lang: LANG_C :: FLang
- IRTS.Lang: LANG_JAVA :: FCallType -> FLang
- IRTS.Lang: LPrintNum :: PrimFn
- IRTS.Lang: LPrintStr :: PrimFn
- IRTS.Lang: data FLang
- IRTS.Lang: instance Eq FLang
- IRTS.Lang: instance Show FLang
- Idris.AbsSyntax: renderWidth :: Idris Int
- Idris.AbsSyntax: setIdeSlave :: Bool -> Handle -> Idris ()
- Idris.AbsSyntaxTree: IdeSlave :: Integer -> Handle -> OutputMode
- Idris.AbsSyntaxTree: Ideslave :: Opt
- Idris.AbsSyntaxTree: IdeslaveSocket :: Opt
- Idris.AbsSyntaxTree: bindingOf :: Name -> Bool -> Doc OutputAnnotation
- Idris.Core.Elaborate: Eval :: Raw -> Command
- Idris.Core.Elaborate: Print :: Name -> Command
- Idris.Core.Elaborate: Quit :: Command
- Idris.Core.Elaborate: Tac :: (Elab ()) -> Command
- Idris.Core.Elaborate: Theorem :: Name -> Raw -> Command
- Idris.Core.Elaborate: data Command
- Idris.Docs: data Docs
- Idris.Docs: data FunDoc
- Idris.ElabTerm: reflectQuote :: [Name] -> Term -> Raw
- Idris.ElabTerm: reflectQuotePattern :: [Name] -> Term -> ElabD ()
- Idris.IdeSlave: AddClause :: Int -> String -> IdeSlaveCommand
- Idris.IdeSlave: AddMissing :: Int -> String -> IdeSlaveCommand
- Idris.IdeSlave: AddProofClause :: Int -> String -> IdeSlaveCommand
- Idris.IdeSlave: Apropos :: String -> IdeSlaveCommand
- Idris.IdeSlave: BoolAtom :: Bool -> SExp
- Idris.IdeSlave: CallsWho :: String -> IdeSlaveCommand
- Idris.IdeSlave: CaseSplit :: Int -> String -> IdeSlaveCommand
- Idris.IdeSlave: DocsFor :: String -> IdeSlaveCommand
- Idris.IdeSlave: ErrContext :: Opt
- Idris.IdeSlave: ErrPPrint :: Err -> IdeSlaveCommand
- Idris.IdeSlave: ErrString :: Err -> IdeSlaveCommand
- Idris.IdeSlave: GetOpts :: IdeSlaveCommand
- Idris.IdeSlave: IntegerAtom :: Integer -> SExp
- Idris.IdeSlave: Interpret :: String -> IdeSlaveCommand
- Idris.IdeSlave: LoadFile :: String -> (Maybe Int) -> IdeSlaveCommand
- Idris.IdeSlave: MakeLemma :: Int -> String -> IdeSlaveCommand
- Idris.IdeSlave: MakeWithBlock :: Int -> String -> IdeSlaveCommand
- Idris.IdeSlave: Metavariables :: Int -> IdeSlaveCommand
- Idris.IdeSlave: PrintDef :: String -> IdeSlaveCommand
- Idris.IdeSlave: ProofSearch :: Bool -> Int -> String -> [String] -> (Maybe Int) -> IdeSlaveCommand
- Idris.IdeSlave: REPLCompletions :: String -> IdeSlaveCommand
- Idris.IdeSlave: SetOpt :: Opt -> Bool -> IdeSlaveCommand
- Idris.IdeSlave: SexpList :: [SExp] -> SExp
- Idris.IdeSlave: ShowImpl :: Opt
- Idris.IdeSlave: StringAtom :: String -> SExp
- Idris.IdeSlave: SymbolAtom :: String -> SExp
- Idris.IdeSlave: TermNoImplicits :: [(Name, Bool)] -> Term -> IdeSlaveCommand
- Idris.IdeSlave: TermNormalise :: [(Name, Bool)] -> Term -> IdeSlaveCommand
- Idris.IdeSlave: TermShowImplicits :: [(Name, Bool)] -> Term -> IdeSlaveCommand
- Idris.IdeSlave: TypeOf :: String -> IdeSlaveCommand
- Idris.IdeSlave: WhoCalls :: String -> IdeSlaveCommand
- Idris.IdeSlave: class SExpable a
- Idris.IdeSlave: convSExp :: SExpable a => String -> a -> Integer -> String
- Idris.IdeSlave: data IdeSlaveCommand
- Idris.IdeSlave: data Opt
- Idris.IdeSlave: data SExp
- Idris.IdeSlave: getLen :: Handle -> IO (Either Err Int)
- Idris.IdeSlave: getNChar :: Handle -> Int -> String -> IO (String)
- Idris.IdeSlave: ideSlaveEpoch :: Int
- Idris.IdeSlave: instance [incoherent] (SExpable a, SExpable b) => SExpable (a, b)
- Idris.IdeSlave: instance [incoherent] (SExpable a, SExpable b, SExpable c) => SExpable (a, b, c)
- Idris.IdeSlave: instance [incoherent] (SExpable a, SExpable b, SExpable c, SExpable d) => SExpable (a, b, c, d)
- Idris.IdeSlave: instance [incoherent] (SExpable a, SExpable b, SExpable c, SExpable d, SExpable e) => SExpable (a, b, c, d, e)
- Idris.IdeSlave: instance [incoherent] Eq SExp
- Idris.IdeSlave: instance [incoherent] SExpable Bool
- Idris.IdeSlave: instance [incoherent] SExpable FC
- Idris.IdeSlave: instance [incoherent] SExpable Int
- Idris.IdeSlave: instance [incoherent] SExpable Integer
- Idris.IdeSlave: instance [incoherent] SExpable Name
- Idris.IdeSlave: instance [incoherent] SExpable NameOutput
- Idris.IdeSlave: instance [incoherent] SExpable OutputAnnotation
- Idris.IdeSlave: instance [incoherent] SExpable SExp
- Idris.IdeSlave: instance [incoherent] SExpable String
- Idris.IdeSlave: instance [incoherent] SExpable a => SExpable (Maybe a)
- Idris.IdeSlave: instance [incoherent] SExpable a => SExpable [a]
- Idris.IdeSlave: instance [incoherent] Show Opt
- Idris.IdeSlave: instance [incoherent] Show SExp
- Idris.IdeSlave: parseMessage :: String -> Either Err (SExp, Integer)
- Idris.IdeSlave: sexpToCommand :: SExp -> Maybe IdeSlaveCommand
- Idris.IdeSlave: toSExp :: SExpable a => a -> SExp
- Idris.Output: ideSlaveReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()
- Idris.Output: ideSlaveReturnWithStatus :: String -> Integer -> Handle -> Doc OutputAnnotation -> Idris ()
- Idris.Output: ideslavePutSExp :: SExpable a => String -> a -> Idris ()
- Idris.REPL: ideSlaveForceTermImplicits :: Handle -> Integer -> [(Name, Bool)] -> Bool -> Term -> Idris ()
- Idris.REPL: ideslave :: Handle -> IState -> [FilePath] -> Idris ()
- Idris.REPL: ideslaveProcess :: FilePath -> Command -> Idris ()
- Idris.REPL: ideslaveStart :: Bool -> IState -> [FilePath] -> Idris ()
- Idris.REPL: initIdeslaveSocket :: IO Handle
- Idris.REPL: runIdeSlaveCommand :: Handle -> Integer -> IState -> FilePath -> [FilePath] -> IdeSlaveCommand -> Idris ()
+ IRTS.CodegenCommon: exportDecls :: CodegenInfo -> [ExportIFace]
+ IRTS.CodegenCommon: interfaces :: CodegenInfo -> Bool
+ IRTS.Exports: findExports :: Idris [ExportIFace]
+ IRTS.Exports: getExpNames :: [ExportIFace] -> [Name]
+ IRTS.Lang: Export :: Name -> String -> [Export] -> ExportIFace
+ IRTS.Lang: ExportData :: FDesc -> Export
+ IRTS.Lang: ExportFun :: Name -> FDesc -> FDesc -> [FDesc] -> Export
+ IRTS.Lang: FApp :: Name -> [FDesc] -> FDesc
+ IRTS.Lang: FCon :: Name -> FDesc
+ IRTS.Lang: FIO :: FDesc -> FDesc
+ IRTS.Lang: FStr :: String -> FDesc
+ IRTS.Lang: FUnknown :: FDesc
+ IRTS.Lang: LReadFile :: PrimFn
+ IRTS.Lang: LWriteFile :: PrimFn
+ IRTS.Lang: LWriteStr :: PrimFn
+ IRTS.Lang: data Export
+ IRTS.Lang: data ExportIFace
+ IRTS.Lang: data FDesc
+ IRTS.Lang: instance Eq Export
+ IRTS.Lang: instance Eq ExportIFace
+ IRTS.Lang: instance Eq FDesc
+ IRTS.Lang: instance Show Export
+ IRTS.Lang: instance Show ExportIFace
+ IRTS.Lang: instance Show FDesc
+ Idris.AbsSyntax: addErasureUsage :: Name -> Int -> Idris ()
+ Idris.AbsSyntax: addExport :: Name -> Idris ()
+ Idris.AbsSyntax: addUsedName :: FC -> Name -> Name -> Idris ()
+ Idris.AbsSyntax: getErasureUsage :: Idris [(Name, Int)]
+ Idris.AbsSyntax: getExports :: Idris [Name]
+ Idris.AbsSyntax: setIdeMode :: Bool -> Handle -> Idris ()
+ Idris.AbsSyntax: updateIState :: (IState -> IState) -> Idris ()
+ Idris.AbsSyntaxTree: Claim :: Name -> t -> PTactic' t
+ Idris.AbsSyntaxTree: Core :: PTerm -> Command
+ Idris.AbsSyntaxTree: FullDocs :: HowMuchDocs
+ Idris.AbsSyntaxTree: IBCExport :: Name -> IBCWrite
+ Idris.AbsSyntaxTree: IBCUsage :: (Name, Int) -> IBCWrite
+ Idris.AbsSyntaxTree: IdeMode :: Integer -> Handle -> OutputMode
+ Idris.AbsSyntaxTree: Idemode :: Opt
+ Idris.AbsSyntaxTree: IdemodeSocket :: Opt
+ Idris.AbsSyntaxTree: Interface :: Opt
+ Idris.AbsSyntaxTree: OverviewDocs :: HowMuchDocs
+ Idris.AbsSyntaxTree: PAppImpl :: PTerm -> [ImplicitInfo] -> PTerm
+ Idris.AbsSyntaxTree: PRunTactics :: FC -> PTerm -> PTerm
+ Idris.AbsSyntaxTree: Unfocus :: PTactic' t
+ Idris.AbsSyntaxTree: UseConsoleWidth :: ConsoleWidth -> Opt
+ Idris.AbsSyntaxTree: catchError :: Idris a -> (Err -> Idris a) -> Idris a
+ Idris.AbsSyntaxTree: class_determiners :: ClassInfo -> [Int]
+ Idris.AbsSyntaxTree: containsHole :: PTerm -> Bool
+ Idris.AbsSyntaxTree: data HowMuchDocs
+ Idris.AbsSyntaxTree: highestFC :: PTerm -> Maybe FC
+ Idris.AbsSyntaxTree: idris_erasureUsed :: IState -> [(Name, Int)]
+ Idris.AbsSyntaxTree: idris_exports :: IState -> [Name]
+ Idris.AbsSyntaxTree: imp_methods :: SyntaxInfo -> [Name]
+ Idris.AbsSyntaxTree: instance Eq ConsoleWidth
+ Idris.AbsSyntaxTree: instance Show ConsoleWidth
+ Idris.AbsSyntaxTree: isHoleName :: Name -> Bool
+ Idris.AbsSyntaxTree: new_tyDecls :: EState -> [(Name, FC, [PArg], Type)]
+ Idris.AbsSyntaxTree: throwError :: Err -> Idris a
+ Idris.AbsSyntaxTree: upairCon :: Name
+ Idris.AbsSyntaxTree: upairTy :: Name
+ Idris.CmdOptions: integerReader :: ReadP Int
+ Idris.CmdOptions: parseConsoleWidth :: Monad m => String -> m ConsoleWidth
+ Idris.Core.Binary: instance Binary Provenance
+ Idris.Core.DeepSeq: instance NFData Provenance
+ Idris.Core.Elaborate: claimFn :: Name -> Name -> Raw -> Elab' aux ()
+ Idris.Core.Elaborate: debugElaborator :: Maybe String -> Elab' aux a
+ Idris.Core.Elaborate: tryCatch :: Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a
+ Idris.Core.Elaborate: unifyGoal :: Raw -> Elab' aux ()
+ Idris.Core.Evaluate: canBeDConName :: Name -> Context -> Bool
+ Idris.Core.Evaluate: case_alwaysinline :: CaseInfo -> Bool
+ Idris.Core.Evaluate: lookupP_all :: Bool -> Name -> Context -> [Term]
+ Idris.Core.ProofState: ClaimFn :: Name -> Name -> Raw -> Tactic
+ Idris.Core.ProofState: UnifyGoal :: Raw -> Tactic
+ Idris.Core.ProofState: getProvenance :: Err -> (Maybe Provenance, Maybe Provenance)
+ Idris.Core.TT: ElabDebug :: (Maybe String) -> t -> [(Name, t, [(Name, Binder t)])] -> Err' t
+ Idris.Core.TT: ExpectedType :: Provenance
+ Idris.Core.TT: GivenVal :: Provenance
+ Idris.Core.TT: InferredVal :: Provenance
+ Idris.Core.TT: InvalidTCArg :: Name -> t -> Err' t
+ Idris.Core.TT: NoEliminator :: String -> t -> Err' t
+ Idris.Core.TT: SourceTerm :: Term -> Provenance
+ Idris.Core.TT: TheWorld :: Const
+ Idris.Core.TT: TooManyArgs :: Term -> Provenance
+ Idris.Core.TT: WorldType :: Const
+ Idris.Core.TT: bindingOf :: Name -> Bool -> Doc OutputAnnotation
+ Idris.Core.TT: data Provenance
+ Idris.Core.TT: instance Data Provenance
+ Idris.Core.TT: instance Eq Provenance
+ Idris.Core.TT: instance Ord FC
+ Idris.Core.TT: instance Ord UConstraint
+ Idris.Core.TT: instance Show Provenance
+ Idris.Core.TT: instance Typeable Provenance
+ Idris.Core.TT: pprintTT :: [Name] -> TT Name -> Doc OutputAnnotation
+ Idris.Core.TT: safeForget :: TT Name -> Maybe Raw
+ Idris.Core.TT: safeForgetEnv :: [Name] -> TT Name -> Maybe Raw
+ Idris.DSL: dslify :: SyntaxInfo -> IState -> PTerm -> PTerm
+ Idris.DSL: mkTTName :: FC -> Name -> PTerm
+ Idris.Delaborate: annName :: Name -> Doc OutputAnnotation
+ Idris.Docs: NamedInstanceDoc :: Name -> (FunDoc' d) -> Docs' d
+ Idris.Docs: data Docs' d
+ Idris.Docs: data FunDoc' d
+ Idris.Docs: instance Functor Docs'
+ Idris.Docs: instance Functor FunDoc'
+ Idris.Docs: type Docs = Docs' (Docstring DocTerm)
+ Idris.Docs: type FunDoc = FunDoc' (Docstring DocTerm)
+ Idris.Elab.Utils: iderr :: Name -> Err -> Err
+ Idris.ElabTerm: ElabResult :: Term -> [(Name, (Int, Maybe Name, Type))] -> [PDecl] -> Context -> [(Name, FC, [PArg], Type)] -> ElabResult
+ Idris.ElabTerm: data ElabResult
+ Idris.ElabTerm: e_isfn :: ElabCtxt -> Bool
+ Idris.ElabTerm: processTacticDecls :: [(Name, FC, [PArg], Type)] -> Idris ()
+ Idris.ElabTerm: reflectBinderQuotePattern :: ([Name] -> a -> ElabD ()) -> [Name] -> Binder a -> ElabD ()
+ Idris.ElabTerm: reflectFC :: FC -> 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: reflectUniverse :: Universe -> Raw
+ Idris.ElabTerm: reifyReportParts :: Term -> ElabD [ErrorReportPart]
+ Idris.ElabTerm: reifyTyDecl :: Term -> ElabD RTyDecl
+ 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: runTactical :: FC -> Env -> Term -> ElabD ()
+ Idris.ElabTerm: tacN :: String -> Name
+ Idris.IBC: ibc_exports :: IBCFile -> ![Name]
+ Idris.IBC: ibc_usage :: IBCFile -> ![(Name, Int)]
+ Idris.IBC: instance Binary t => Binary (ProvideWhat' t)
+ Idris.IBC: pExports :: [Name] -> Idris ()
+ Idris.IBC: pUsage :: [(Name, Int)] -> Idris ()
+ Idris.IdeMode: AddClause :: Int -> String -> IdeModeCommand
+ Idris.IdeMode: AddMissing :: Int -> String -> IdeModeCommand
+ Idris.IdeMode: AddProofClause :: Int -> String -> IdeModeCommand
+ Idris.IdeMode: Apropos :: String -> IdeModeCommand
+ Idris.IdeMode: BoolAtom :: Bool -> SExp
+ Idris.IdeMode: CallsWho :: String -> IdeModeCommand
+ Idris.IdeMode: CaseSplit :: Int -> String -> IdeModeCommand
+ Idris.IdeMode: DocsFor :: String -> WhatDocs -> IdeModeCommand
+ Idris.IdeMode: ErrContext :: Opt
+ Idris.IdeMode: ErrPPrint :: Err -> IdeModeCommand
+ Idris.IdeMode: ErrString :: Err -> IdeModeCommand
+ Idris.IdeMode: Full :: WhatDocs
+ Idris.IdeMode: GetIdrisVersion :: IdeModeCommand
+ Idris.IdeMode: GetOpts :: IdeModeCommand
+ Idris.IdeMode: IntegerAtom :: Integer -> SExp
+ Idris.IdeMode: Interpret :: String -> IdeModeCommand
+ Idris.IdeMode: LoadFile :: String -> (Maybe Int) -> IdeModeCommand
+ Idris.IdeMode: MakeLemma :: Int -> String -> IdeModeCommand
+ Idris.IdeMode: MakeWithBlock :: Int -> String -> IdeModeCommand
+ Idris.IdeMode: Metavariables :: Int -> IdeModeCommand
+ Idris.IdeMode: Overview :: WhatDocs
+ Idris.IdeMode: PrintDef :: String -> IdeModeCommand
+ Idris.IdeMode: ProofSearch :: Bool -> Int -> String -> [String] -> (Maybe Int) -> IdeModeCommand
+ Idris.IdeMode: REPLCompletions :: String -> IdeModeCommand
+ Idris.IdeMode: SetOpt :: Opt -> Bool -> IdeModeCommand
+ Idris.IdeMode: SexpList :: [SExp] -> SExp
+ Idris.IdeMode: ShowImpl :: Opt
+ Idris.IdeMode: StringAtom :: String -> SExp
+ Idris.IdeMode: SymbolAtom :: String -> SExp
+ Idris.IdeMode: TermElab :: [(Name, Bool)] -> Term -> IdeModeCommand
+ Idris.IdeMode: TermNoImplicits :: [(Name, Bool)] -> Term -> IdeModeCommand
+ Idris.IdeMode: TermNormalise :: [(Name, Bool)] -> Term -> IdeModeCommand
+ Idris.IdeMode: TermShowImplicits :: [(Name, Bool)] -> Term -> IdeModeCommand
+ Idris.IdeMode: TypeOf :: String -> IdeModeCommand
+ Idris.IdeMode: WhoCalls :: String -> IdeModeCommand
+ Idris.IdeMode: class SExpable a
+ Idris.IdeMode: convSExp :: SExpable a => String -> a -> Integer -> String
+ Idris.IdeMode: data IdeModeCommand
+ Idris.IdeMode: data Opt
+ Idris.IdeMode: data SExp
+ Idris.IdeMode: data WhatDocs
+ Idris.IdeMode: getLen :: Handle -> IO (Either Err Int)
+ Idris.IdeMode: getNChar :: Handle -> Int -> String -> IO (String)
+ Idris.IdeMode: ideModeEpoch :: Int
+ Idris.IdeMode: instance [incoherent] (SExpable a, SExpable b) => SExpable (a, b)
+ Idris.IdeMode: instance [incoherent] (SExpable a, SExpable b, SExpable c) => SExpable (a, b, c)
+ Idris.IdeMode: instance [incoherent] (SExpable a, SExpable b, SExpable c, SExpable d) => SExpable (a, b, c, d)
+ Idris.IdeMode: instance [incoherent] (SExpable a, SExpable b, SExpable c, SExpable d, SExpable e) => SExpable (a, b, c, d, e)
+ Idris.IdeMode: instance [incoherent] Eq SExp
+ Idris.IdeMode: instance [incoherent] SExpable Bool
+ Idris.IdeMode: instance [incoherent] SExpable FC
+ Idris.IdeMode: instance [incoherent] SExpable Int
+ Idris.IdeMode: instance [incoherent] SExpable Integer
+ Idris.IdeMode: instance [incoherent] SExpable Name
+ Idris.IdeMode: instance [incoherent] SExpable NameOutput
+ Idris.IdeMode: instance [incoherent] SExpable OutputAnnotation
+ Idris.IdeMode: instance [incoherent] SExpable SExp
+ Idris.IdeMode: instance [incoherent] SExpable String
+ Idris.IdeMode: instance [incoherent] SExpable a => SExpable (Maybe a)
+ Idris.IdeMode: instance [incoherent] SExpable a => SExpable [a]
+ Idris.IdeMode: instance [incoherent] Show Opt
+ Idris.IdeMode: instance [incoherent] Show SExp
+ Idris.IdeMode: parseMessage :: String -> Either Err (SExp, Integer)
+ Idris.IdeMode: sexpToCommand :: SExp -> Maybe IdeModeCommand
+ Idris.IdeMode: toSExp :: SExpable a => a -> SExp
+ Idris.Imports: caseSensitive :: (FilePath -> IO Bool) -> FilePath -> IO Bool
+ Idris.Imports: doesDirectoryExist' :: FilePath -> IO Bool
+ Idris.Imports: doesFileExist' :: FilePath -> IO Bool
+ Idris.Output: ideModeReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()
+ Idris.Output: ideModeReturnWithStatus :: String -> Integer -> Handle -> Doc OutputAnnotation -> Idris ()
+ Idris.Output: idemodePutSExp :: SExpable a => String -> a -> Idris ()
+ Idris.ParseExpr: runTactics :: SyntaxInfo -> IdrisParser PTerm
+ Idris.ParseHelpers: commentMarkers :: [String]
+ Idris.ParseHelpers: invalidOperators :: [String]
+ Idris.ParseOps: nofixityoperator :: Operator IdrisParser PTerm
+ Idris.Parser: docstring :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))])
+ Idris.REPL: getConsoleWidth :: Opt -> Maybe ConsoleWidth
+ Idris.REPL: ideModeForceTermImplicits :: Handle -> Integer -> [(Name, Bool)] -> Bool -> Term -> Idris ()
+ Idris.REPL: idemode :: Handle -> IState -> [FilePath] -> Idris ()
+ Idris.REPL: idemodeProcess :: FilePath -> Command -> Idris ()
+ Idris.REPL: idemodeStart :: Bool -> IState -> [FilePath] -> Idris ()
+ Idris.REPL: initIdemodeSocket :: IO Handle
+ Idris.REPL: runIdeModeCommand :: Handle -> Integer -> IState -> FilePath -> [FilePath] -> IdeModeCommand -> Idris ()
+ Idris.Reflection: RConstraint :: Name -> Raw -> RArg
+ Idris.Reflection: RDeclare :: Name -> [RArg] -> Raw -> RTyDecl
+ Idris.Reflection: RExplicit :: Name -> Raw -> RArg
+ Idris.Reflection: RImplicit :: Name -> Raw -> RArg
+ Idris.Reflection: argName :: RArg -> Name
+ Idris.Reflection: argTy :: RArg -> Raw
+ Idris.Reflection: data RArg
+ Idris.Reflection: data RTyDecl
+ Idris.Reflection: rArgToPArg :: RArg -> PArg
+ Util.System: isWindows :: Bool
- IRTS.Bytecode: FOREIGNCALL :: Reg -> FLang -> FType -> String -> [(FType, Reg)] -> BC
+ IRTS.Bytecode: FOREIGNCALL :: Reg -> FDesc -> FDesc -> [(FDesc, Reg)] -> BC
- IRTS.CodegenCommon: CodegenInfo :: String -> OutputType -> String -> String -> [FilePath] -> [FilePath] -> [String] -> [String] -> [String] -> DbgLevel -> [(Name, SDecl)] -> [(Name, DDecl)] -> [(Name, LDecl)] -> CodegenInfo
+ IRTS.CodegenCommon: CodegenInfo :: String -> OutputType -> String -> String -> [FilePath] -> [FilePath] -> [String] -> [String] -> [String] -> DbgLevel -> [(Name, SDecl)] -> [(Name, DDecl)] -> [(Name, LDecl)] -> Bool -> [ExportIFace] -> CodegenInfo
- IRTS.Compiler: compile :: Codegen -> FilePath -> Term -> Idris CodegenInfo
+ IRTS.Compiler: compile :: Codegen -> FilePath -> Maybe Term -> Idris CodegenInfo
- IRTS.Defunctionalise: DForeign :: FLang -> FType -> String -> [(FType, DExp)] -> DExp
+ IRTS.Defunctionalise: DForeign :: FDesc -> FDesc -> [(FDesc, DExp)] -> DExp
- IRTS.Lang: LForeign :: FLang -> FType -> String -> [(FType, LExp)] -> LExp
+ IRTS.Lang: LForeign :: FDesc -> FDesc -> [(FDesc, LExp)] -> LExp
- IRTS.Simplified: SForeign :: FLang -> FType -> String -> [(FType, LVar)] -> SExp
+ IRTS.Simplified: SForeign :: FDesc -> FDesc -> [(FDesc, LVar)] -> SExp
- Idris.AbsSyntax: addImpl :: IState -> PTerm -> PTerm
+ Idris.AbsSyntax: addImpl :: [Name] -> IState -> PTerm -> PTerm
- Idris.AbsSyntax: addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm
+ Idris.AbsSyntax: addImpl' :: Bool -> [Name] -> [Name] -> [Name] -> IState -> PTerm -> PTerm
- Idris.AbsSyntax: aiFn :: Bool -> Bool -> Bool -> IState -> FC -> Name -> [[Text]] -> [PArg] -> Either Err PTerm
+ Idris.AbsSyntax: aiFn :: Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -> [[Text]] -> [PArg] -> Either Err PTerm
- Idris.AbsSyntaxTree: CI :: Name -> [(Name, (FnOpts, PTerm))] -> [(Name, (Name, PDecl))] -> [PDecl] -> [Name] -> [Name] -> ClassInfo
+ Idris.AbsSyntaxTree: CI :: Name -> [(Name, (FnOpts, PTerm))] -> [(Name, (Name, PDecl))] -> [PDecl] -> [Name] -> [Name] -> [Int] -> ClassInfo
- Idris.AbsSyntaxTree: DocStr :: (Either Name Const) -> Command
+ Idris.AbsSyntaxTree: DocStr :: (Either Name Const) -> HowMuchDocs -> Command
- Idris.AbsSyntaxTree: EState :: [PDecl] -> [Elab' EState ()] -> EState
+ Idris.AbsSyntaxTree: EState :: [PDecl] -> [Elab' EState ()] -> [(Name, FC, [PArg], Type)] -> EState
- Idris.AbsSyntaxTree: IState :: Context -> [(UConstraint, FC)] -> [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 -> Maybe (Map Name [Name]) -> Maybe (Map Name [Name]) -> [Name] -> [Name] -> Map Name Name -> IState
+ Idris.AbsSyntaxTree: IState :: Context -> [(UConstraint, FC)] -> [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: PClass :: (Docstring (Either Err PTerm)) -> SyntaxInfo -> FC -> [(Name, t)] -> Name -> [(Name, t)] -> [(Name, Docstring (Either Err PTerm))] -> [PDecl' t] -> PDecl' t
+ 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: PInstance :: 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 -> [t] -> t -> (Maybe Name) -> [PDecl' t] -> PDecl' t
- Idris.AbsSyntaxTree: PProvider :: SyntaxInfo -> FC -> (ProvideWhat' t) -> Name -> PDecl' t
+ Idris.AbsSyntaxTree: PProvider :: (Docstring (Either Err PTerm)) -> SyntaxInfo -> FC -> (ProvideWhat' t) -> Name -> PDecl' t
- Idris.AbsSyntaxTree: PWith :: FC -> Name -> t -> [t] -> t -> [PDecl' t] -> PClause' t
+ Idris.AbsSyntaxTree: PWith :: FC -> Name -> t -> [t] -> t -> (Maybe Name) -> [PDecl' t] -> PClause' t
- Idris.AbsSyntaxTree: PWithR :: FC -> [t] -> t -> [PDecl' t] -> PClause' t
+ Idris.AbsSyntaxTree: PWithR :: FC -> [t] -> t -> (Maybe Name) -> [PDecl' t] -> PClause' t
- Idris.AbsSyntaxTree: Syn :: [Using] -> [(Name, PTerm)] -> [String] -> [Name] -> (Name -> Name) -> Bool -> Bool -> Maybe Int -> Int -> DSL -> Int -> SyntaxInfo
+ Idris.AbsSyntaxTree: Syn :: [Using] -> [(Name, PTerm)] -> [String] -> [Name] -> [Name] -> (Name -> Name) -> Bool -> Bool -> Maybe Int -> Int -> DSL -> Int -> SyntaxInfo
- Idris.Core.Elaborate: get_guess :: Elab' aux Type
+ Idris.Core.Elaborate: get_guess :: Elab' aux Term
- Idris.Core.Elaborate: simple_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux ()
+ Idris.Core.Elaborate: simple_app :: Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()
- Idris.Core.Evaluate: CaseInfo :: Bool -> Bool -> CaseInfo
+ Idris.Core.Evaluate: CaseInfo :: Bool -> Bool -> Bool -> CaseInfo
- Idris.Core.ProofTerm: updateSolvedTerm' :: [(Name, TT Name)] -> TT Name -> (TT Name, Bool)
+ Idris.Core.ProofTerm: updateSolvedTerm' :: [(Name, Term)] -> Term -> (Term, Bool)
- Idris.Core.TT: CantResolve :: t -> Err' t
+ Idris.Core.TT: CantResolve :: Bool -> t -> Err' t
- Idris.Core.TT: CantUnify :: Bool -> t -> t -> (Err' t) -> [(Name, t)] -> Int -> Err' t
+ Idris.Core.TT: CantUnify :: Bool -> (t, Maybe Provenance) -> (t, Maybe Provenance) -> (Err' t) -> [(Name, t)] -> Int -> Err' t
- Idris.Core.TT: addAlist :: Show a => [(Name, a)] -> Ctxt a -> Ctxt a
+ Idris.Core.TT: addAlist :: [(Name, a)] -> Ctxt a -> Ctxt a
- Idris.Core.Unify: match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] -> TC [(Name, TT Name)]
+ Idris.Core.Unify: match_unify :: Context -> Env -> (TT Name, Maybe Provenance) -> (TT Name, Maybe Provenance) -> [Name] -> [Name] -> [FailContext] -> TC [(Name, TT Name)]
- Idris.Core.Unify: unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [Name] -> [FailContext] -> TC ([(Name, TT Name)], Fails)
+ Idris.Core.Unify: unify :: Context -> Env -> (TT Name, Maybe Provenance) -> (TT Name, Maybe Provenance) -> [Name] -> [Name] -> [Name] -> [FailContext] -> TC ([(Name, TT Name)], Fails)
- Idris.Docs: ClassDoc :: Name -> (Docstring DocTerm) -> [FunDoc] -> [(Name, Maybe (Docstring DocTerm))] -> [PTerm] -> [PTerm] -> Docs
+ Idris.Docs: ClassDoc :: Name -> d -> [FunDoc' d] -> [(Name, Maybe d)] -> [(Maybe Name, PTerm, (d, [(Name, d)]))] -> [PTerm] -> [PTerm] -> Docs' d
- Idris.Docs: DataDoc :: FunDoc -> [FunDoc] -> Docs
+ Idris.Docs: DataDoc :: (FunDoc' d) -> [FunDoc' d] -> Docs' d
- Idris.Docs: FD :: Name -> (Docstring DocTerm) -> [(Name, PTerm, Plicity, Maybe (Docstring DocTerm))] -> PTerm -> (Maybe Fixity) -> FunDoc
+ Idris.Docs: FD :: Name -> d -> [(Name, PTerm, Plicity, Maybe d)] -> PTerm -> (Maybe Fixity) -> FunDoc' d
- Idris.Docs: FunDoc :: FunDoc -> Docs
+ Idris.Docs: FunDoc :: (FunDoc' d) -> Docs' d
- Idris.Docs: ModDoc :: [String] -> (Docstring DocTerm) -> Docs
+ Idris.Docs: ModDoc :: [String] -> d -> Docs' d
- Idris.Docs: getDocs :: Name -> Idris Docs
+ Idris.Docs: getDocs :: Name -> HowMuchDocs -> Idris Docs
- Idris.Elab.Class: elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> FC -> [(Name, PTerm)] -> Name -> [(Name, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [PDecl] -> Idris ()
+ 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.Instance: elabInstance :: ElabInfo -> SyntaxInfo -> 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 -> [PTerm] -> PTerm -> Maybe Name -> [PDecl] -> Idris ()
- Idris.Elab.Provider: elabProvider :: ElabInfo -> SyntaxInfo -> FC -> ProvideWhat -> Name -> Idris ()
+ Idris.Elab.Provider: elabProvider :: Docstring (Either Err PTerm) -> ElabInfo -> SyntaxInfo -> FC -> ProvideWhat -> Name -> Idris ()
- Idris.Elab.Utils: checkAddDef :: Bool -> Bool -> FC -> [(Name, (Int, Maybe Name, TT Name))] -> StateT IState (ExceptT Err IO) [(Name, (Int, Maybe Name, Term))]
+ Idris.Elab.Utils: checkAddDef :: Bool -> Bool -> FC -> (Name -> Err -> Err) -> [(Name, (Int, Maybe Name, Type))] -> Idris [(Name, (Int, Maybe Name, Type))]
- Idris.Elab.Utils: checkDef :: FC -> [(Name, (Int, Maybe Name, TT Name))] -> StateT IState (ExceptT Err IO) [(Name, (Int, Maybe Name, Term))]
+ Idris.Elab.Utils: checkDef :: FC -> (Name -> Err -> Err) -> [(Name, (Int, Maybe Name, Type))] -> Idris [(Name, (Int, Maybe Name, Type))]
- Idris.Elab.Utils: recheckC :: FC -> Env -> TT Name -> StateT IState (ExceptT Err IO) (Term, Type)
+ Idris.Elab.Utils: recheckC :: FC -> (Err' (TT Name) -> Err) -> Env -> TT Name -> StateT IState (ExceptT Err IO) (Term, Type)
- Idris.Elab.Utils: recheckC_borrowing :: Bool -> [Name] -> FC -> Env -> TT Name -> StateT IState (ExceptT Err IO) (Term, Type)
+ Idris.Elab.Utils: recheckC_borrowing :: Bool -> [Name] -> FC -> (Err' (TT Name) -> Err) -> Env -> TT Name -> StateT IState (ExceptT Err IO) (Term, Type)
- Idris.ElabTerm: ElabCtxt :: Bool -> Bool -> Bool -> Bool -> Bool -> ElabCtxt
+ Idris.ElabTerm: ElabCtxt :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> ElabCtxt
- Idris.ElabTerm: build :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])
+ Idris.ElabTerm: build :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ElabResult
- Idris.ElabTerm: buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])
+ Idris.ElabTerm: buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ElabResult
- Idris.ElabTerm: reflectBinderQuote :: [Name] -> Binder Term -> Raw
+ Idris.ElabTerm: reflectBinderQuote :: ([Name] -> a -> Raw) -> Name -> [Name] -> Binder a -> Raw
- Idris.ElabTerm: resTC' :: (Num a, Eq a) => [TT Name] -> Bool -> a -> Term -> Name -> IState -> StateT (ElabState EState) TC ()
+ Idris.ElabTerm: resTC' :: (Num a, Eq a) => [TT Name] -> Bool -> [Name] -> a -> Term -> Name -> IState -> StateT (ElabState EState) TC ()
- Idris.ElabTerm: resolveTC :: Bool -> Int -> Term -> Name -> IState -> ElabD ()
+ Idris.ElabTerm: resolveTC :: Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
- Idris.Erasure: performUsageAnalysis :: Idris [Name]
+ Idris.Erasure: performUsageAnalysis :: [Name] -> Idris [Name]
- 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) -> IBCFile
+ 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.Parser: loadModule' :: FilePath -> Idris String
+ Idris.Parser: loadModule' :: FilePath -> Idris (Maybe String)
Files
- Makefile +12/−1
- Setup.hs +10/−3
- codegen/idris-c/Main.hs +7/−2
- codegen/idris-javascript/Main.hs +1/−1
- codegen/idris-node/Main.hs +1/−1
- idris.cabal +64/−10
- jsrts/Runtime-common.js +11/−13
- libs/Makefile +10/−5
- libs/base/Control/Arrow.idr +1/−1
- libs/base/Control/IOExcept.idr +2/−2
- libs/base/Control/Isomorphism/Primitives.idr +0/−35
- libs/base/Control/Monad/Identity.idr +1/−1
- libs/base/Control/Monad/RWS.idr +1/−1
- libs/base/Control/Monad/Reader.idr +1/−1
- libs/base/Control/Monad/State.idr +2/−2
- libs/base/Control/Monad/Writer.idr +3/−2
- libs/base/Data/BoundedList.idr +0/−96
- libs/base/Data/Buffer.idr +0/−254
- libs/base/Data/Erased.idr +1/−1
- libs/base/Data/Fin.idr +39/−9
- libs/base/Data/Fun.idr +0/−17
- libs/base/Data/Hash.idr +0/−87
- libs/base/Data/Heap.idr +0/−189
- libs/base/Data/Matrix.idr +0/−256
- libs/base/Data/Morphisms.idr +1/−1
- libs/base/Data/Rel.idr +0/−12
- libs/base/Data/Sign.idr +0/−8
- libs/base/Data/SortedMap.idr +0/−237
- libs/base/Data/VectType.idr +6/−5
- libs/base/Data/ZZ.idr +0/−153
- libs/base/Debug/Error.idr +1/−1
- libs/base/Debug/Trace.idr +1/−1
- libs/base/Decidable/Decidable.idr +0/−23
- libs/base/Decidable/Order.idr +0/−156
- libs/base/Language/Reflection/Utils.idr +2/−0
- libs/base/Network/Cgi.idr +0/−143
- libs/base/Network/Socket.idr +0/−363
- libs/base/Providers.idr +0/−27
- libs/base/System.idr +10/−10
- libs/base/System/Concurrency/Process.idr +0/−61
- libs/base/System/Concurrency/Raw.idr +53/−7
- libs/base/base.ipkg +7/−14
- libs/contrib/Classes/Verified.idr +114/−0
- libs/contrib/Control/Algebra.idr +274/−0
- libs/contrib/Control/Isomorphism/Primitives.idr +35/−0
- libs/contrib/Data/BoundedList.idr +96/−0
- libs/contrib/Data/Buffer.idr +254/−0
- libs/contrib/Data/Fun.idr +17/−0
- libs/contrib/Data/Hash.idr +87/−0
- libs/contrib/Data/Heap.idr +187/−0
- libs/contrib/Data/Matrix.idr +250/−0
- libs/contrib/Data/Rel.idr +12/−0
- libs/contrib/Data/Sign.idr +8/−0
- libs/contrib/Data/SortedMap.idr +237/−0
- libs/contrib/Data/SortedSet.idr +28/−0
- libs/contrib/Data/ZZ.idr +154/−0
- libs/contrib/Decidable/Decidable.idr +23/−0
- libs/contrib/Decidable/Order.idr +156/−0
- libs/contrib/Makefile +24/−0
- libs/contrib/Network/Cgi.idr +143/−0
- libs/contrib/Network/Socket.idr +370/−0
- libs/contrib/System/Concurrency/Process.idr +72/−0
- libs/contrib/contrib.ipkg +18/−0
- libs/effects/Effect/Exception.idr +3/−4
- libs/effects/Effect/Memory.idr +19/−19
- libs/effects/Effect/Monad.idr +1/−1
- libs/effects/Effect/StdIO.idr +18/−7
- libs/effects/Effects.idr +4/−3
- libs/prelude/Builtins.idr +10/−0
- libs/prelude/Decidable/Equality.idr +0/−9
- libs/prelude/IO.idr +185/−105
- libs/prelude/Language/Reflection.idr +205/−37
- libs/prelude/Language/Reflection/Errors.idr +3/−1
- libs/prelude/Language/Reflection/Tactical.idr +138/−0
- libs/prelude/Prelude.idr +66/−43
- libs/prelude/Prelude/Algebra.idr +1/−295
- libs/prelude/Prelude/Applicative.idr +11/−26
- libs/prelude/Prelude/Basics.idr +1/−1
- libs/prelude/Prelude/Foldable.idr +1/−1
- libs/prelude/Prelude/Functor.idr +7/−7
- libs/prelude/Prelude/List.idr +0/−6
- libs/prelude/Prelude/Monad.idr +0/−13
- libs/prelude/Prelude/Nat.idr +3/−13
- libs/prelude/Prelude/Providers.idr +31/−0
- libs/prelude/Prelude/Stream.idr +1/−1
- libs/prelude/Prelude/Strings.idr +88/−59
- libs/prelude/Prelude/Traversable.idr +2/−2
- libs/prelude/prelude.ipkg +2/−2
- rts/Makefile +1/−1
- rts/idris_gc.c +11/−24
- rts/idris_gmp.c +12/−2
- rts/idris_heap.c +8/−5
- rts/idris_heap.h +1/−1
- rts/idris_rts.c +113/−33
- rts/idris_rts.h +35/−10
- rts/idris_stats.h +2/−1
- rts/idris_stdfgn.c +6/−2
- rts/idris_stdfgn.h +2/−1
- rts/windows/idris_stdfgn.c +10/−3
- rts/windows/win_utils.c +21/−0
- src/IRTS/Bytecode.hs +5/−6
- src/IRTS/CodegenC.hs +165/−24
- src/IRTS/CodegenCommon.hs +3/−1
- src/IRTS/CodegenJavaScript.hs +32/−9
- src/IRTS/Compiler.hs +49/−15
- src/IRTS/Defunctionalise.hs +9/−7
- src/IRTS/DumpBC.hs +2/−2
- src/IRTS/Exports.hs +110/−0
- src/IRTS/Lang.hs +35/−14
- src/IRTS/LangOpts.hs +3/−3
- src/IRTS/Simplified.hs +7/−5
- src/IRTS/System.hs +2/−1
- src/Idris/AbsSyntax.hs +119/−54
- src/Idris/AbsSyntaxTree.hs +181/−74
- src/Idris/CmdOptions.hs +36/−3
- src/Idris/Core/Binary.hs +47/−3
- src/Idris/Core/Constraints.hs +2/−1
- src/Idris/Core/DeepSeq.hs +14/−2
- src/Idris/Core/Elaborate.hs +79/−42
- src/Idris/Core/Evaluate.hs +43/−32
- src/Idris/Core/Execute.hs +156/−128
- src/Idris/Core/ProofState.hs +109/−54
- src/Idris/Core/ProofTerm.hs +40/−14
- src/Idris/Core/TT.hs +164/−20
- src/Idris/Core/Typecheck.hs +5/−1
- src/Idris/Core/Unify.hs +34/−26
- src/Idris/Coverage.hs +11/−12
- src/Idris/DSL.hs +48/−9
- src/Idris/DeepSeq.hs +21/−17
- src/Idris/Delaborate.hs +66/−10
- src/Idris/Docs.hs +124/−38
- src/Idris/Elab/Class.hs +47/−30
- src/Idris/Elab/Clause.hs +92/−61
- src/Idris/Elab/Data.hs +6/−3
- src/Idris/Elab/Instance.hs +84/−21
- src/Idris/Elab/Provider.hs +19/−14
- src/Idris/Elab/Transform.hs +14/−8
- src/Idris/Elab/Type.hs +26/−14
- src/Idris/Elab/Utils.hs +25/−17
- src/Idris/Elab/Value.hs +11/−6
- src/Idris/ElabDecls.hs +8/−9
- src/Idris/ElabQuasiquote.hs +3/−0
- src/Idris/ElabTerm.hs +714/−231
- src/Idris/Erasure.hs +36/−21
- src/Idris/Error.hs +3/−2
- src/Idris/IBC.hs +242/−56
- src/Idris/IdeMode.hs +314/−0
- src/Idris/IdeSlave.hs +0/−302
- src/Idris/IdrisDoc.hs +7/−6
- src/Idris/Imports.hs +22/−6
- src/Idris/Interactive.hs +3/−3
- src/Idris/Output.hs +25/−23
- src/Idris/ParseExpr.hs +40/−36
- src/Idris/ParseHelpers.hs +27/−20
- src/Idris/ParseOps.hs +9/−1
- src/Idris/Parser.hs +109/−60
- src/Idris/Primitives.hs +13/−5
- src/Idris/ProofSearch.hs +6/−5
- src/Idris/Prover.hs +22/−22
- src/Idris/Providers.hs +3/−3
- src/Idris/REPL.hs +256/−192
- src/Idris/REPLParser.hs +3/−2
- src/Idris/Reflection.hs +18/−0
- src/Idris/TypeSearch.hs +15/−5
- src/Pkg/PParser.hs +2/−2
- src/Pkg/Package.hs +1/−1
- src/Util/System.hs +5/−1
- test/Makefile +1/−7
- test/basic002/test006.idr +1/−1
- test/basic003/test027.idr +3/−3
- test/basic004/test016.idr +1/−1
- test/basic005/test019.lidr +1/−1
- test/basic006/expected +2/−2
- test/basic006/run +3/−2
- test/basic006/test020.idr +2/−2
- test/basic006/test020a.idr +1/−1
- test/basic007/test033.idr +1/−1
- test/basic009/run +6/−3
- test/basic011/basic011.idr +10/−10
- test/basic011/run +1/−1
- test/basic012/basic012.idr +5/−4
- test/docs001/docs001.idr +20/−0
- test/docs001/expected +17/−0
- test/docs001/input +1/−0
- test/docs001/run +3/−0
- test/docs002/docs002.idr +17/−0
- test/docs002/expected +11/−0
- test/docs002/input +3/−0
- test/docs002/run +3/−0
- test/docs003/docs003.idr +9/−0
- test/docs003/expected +37/−0
- test/docs003/input +3/−0
- test/docs003/run +3/−0
- test/dsl001/test001.idr +6/−3
- test/dsl002/Resimp.idr +6/−1
- test/dsl003/DSLPi.idr +8/−2
- test/effects002/test025.idr +1/−1
- test/error003/expected +2/−1
- test/error003/run +1/−1
- test/error004/expected +6/−3
- test/error004/run +1/−1
- test/error005/error005.idr +7/−0
- test/error005/expected +13/−4
- test/error005/run +1/−1
- test/ffi001/run +1/−1
- test/ffi001/test022.idr +1/−1
- test/ffi002/expected +1/−1
- test/ffi002/run +1/−1
- test/ffi002/test023.idr +0/−2
- test/ffi004/test026.idr +0/−3
- test/ffi005/Postulate.idr +0/−2
- test/ffi006/expected +2/−0
- test/ffi006/ffi006.c +14/−0
- test/ffi006/ffi006.idr +30/−0
- test/ffi006/run +5/−0
- test/interactive007/expected +1/−0
- test/interactive007/input +4/−0
- test/interactive007/run +2/−0
- test/io002/test008.idr +1/−1
- test/io003/run +2/−2
- test/io003/test018a.idr +1/−1
- test/literate001/run +2/−2
- test/primitives001/test005.idr +6/−6
- test/primitives003/expected +0/−2
- test/primitives003/test038.idr +0/−3
- test/proof002/expected +4/−3
- test/proof002/run +2/−2
- test/proof003/test015.idr +3/−3
- test/proof008/ClaimAndUnfocus.idr +17/−0
- test/proof008/expected +0/−0
- test/proof008/run +3/−0
- test/quasiquote001/expected +2/−2
- test/quasiquote003/run +1/−1
- test/quasiquote004/expected +2/−1
- test/quasiquote004/run +1/−1
- test/quasiquote005/Quasiquote005.idr +22/−0
- test/quasiquote005/expected +0/−0
- test/quasiquote005/run +3/−0
- test/records001/test011.idr +5/−5
- test/records003/records003.idr +6/−6
- test/reg002/reg012.idr +1/−1
- test/reg003/run +2/−2
- test/reg004/reg004.idr +1/−1
- test/reg006/expected +2/−1
- test/reg006/run +1/−1
- test/reg007/expected +2/−2
- test/reg007/run +1/−1
- test/reg010/expected +2/−1
- test/reg010/run +1/−1
- test/reg013/reg013.idr +3/−3
- test/reg016/reg016.idr +6/−6
- test/reg017/reg017.idr +1/−1
- test/reg018/expected +10/−5
- test/reg018/reg018d.idr +1/−1
- test/reg018/run +4/−4
- test/reg023/expected +2/−2
- test/reg023/run +1/−1
- test/reg027/expected +2/−1
- test/reg027/reg027.idr +2/−2
- test/reg027/run +2/−2
- test/reg028/expected +4/−2
- test/reg028/run +2/−2
- test/reg029/reg029.idr +2/−2
- test/reg031/reg031.idr +1/−1
- test/reg034/run +1/−1
- test/reg035/run +3/−3
- test/reg040/reg040.idr +1/−1
- test/reg041/ott.idr +1/−1
- test/reg042/reg042.idr +1/−1
- test/reg044/expected +2/−2
- test/reg044/run +1/−1
- test/reg045/reg045.idr +1/−1
- test/reg048/run +1/−1
- test/reg049/run +1/−1
- test/reg050/expected +9/−27
- test/reg051-disabled/expected +0/−0
- test/reg051-disabled/reg051.idr +99/−0
- test/reg051-disabled/run +3/−0
- test/reg051/expected +0/−0
- test/reg051/reg051.idr +0/−99
- test/reg051/run +0/−3
- test/reg052/reg052.idr +1/−1
- test/reg053/four.idr +1/−1
- test/reg054/run +1/−1
- test/reg055/run +2/−2
- test/reg056/run +1/−1
- test/reg058/expected +0/−0
- test/reg058/implicits.idr +14/−0
- test/reg058/implicits2.idr +19/−0
- test/reg058/run +5/−0
- test/reg059/expected +0/−0
- test/reg059/reg059.idr +8/−0
- test/reg059/run +3/−0
- test/reg060/expected +0/−0
- test/reg060/reg060.idr +12/−0
- test/reg060/run +3/−0
- test/sourceLocation001/SourceLoc.idr +7/−5
- test/sourceLocation001/expected +2/−2
- test/sugar001/test007.idr +5/−5
- test/sugar004/sugar004.idr +1/−1
- test/sugar005/As.idr +9/−9
- test/tactics001/Tactics.idr +41/−0
- test/tactics001/expected +0/−0
- test/tactics001/run +3/−0
- test/totality001/expected +6/−3
- test/totality001/run +3/−3
- test/totality002/expected +4/−2
- test/totality002/run +3/−3
- test/totality003/expected +2/−1
- test/totality003/run +2/−2
- test/totality004/expected +4/−2
- test/totality004/run +2/−2
- test/totality004/totality004.idr +1/−1
- test/totality004/totality004a.idr +1/−1
- test/totality005/totality005.idr +1/−1
- test/totality006/expected +4/−1
- test/totality006/run +3/−2
- test/totality006/totality006b.idr +14/−0
- test/totality007/expected +2/−1
- test/totality007/totality.ipkg +1/−1
- test/totality008/expected +2/−1
- test/totality008/run +1/−1
- test/tutorial002/tutorial002.idr +1/−1
- test/tutorial003/tutorial003.idr +1/−1
- test/tutorial006/expected +6/−5
- test/tutorial006/run +2/−2
- test/unique001/expected +3/−2
- test/unique001/run +6/−6
- test/unique001/unique001c.idr +4/−7
- test/unique002/run +2/−2
- test/unique003/run +1/−1
Makefile view
@@ -1,4 +1,4 @@-.PHONY: build configure doc install linecount nodefault pinstall lib_clean relib test_c test lib_doc lib_doc_clean+.PHONY: build configure doc install linecount nodefault pinstall lib_clean relib test_c test lib_doc lib_doc_clean user_doc_html user_doc_pdf user_docs include config.mk -include custom.mk@@ -54,6 +54,17 @@ lib_doc_clean: $(MAKE) -C libs IDRIS=../../dist/build/idris/idris doc_clean++user_docs: user_doc_html user_doc_pdf++user_doc_clean:+ $(MAKE) -C docs clean++user_doc_html:+ $(MAKE) -C docs html++user_doc_pdf:+ $(MAKE) -C docs latexpdf dist/setup-config: $(CABAL) configure $(CABALFLAGS)
Setup.hs view
@@ -57,6 +57,13 @@ Just False -> False Nothing -> True +execOnly :: S.ConfigFlags -> Bool+execOnly flags =+ case lookup (FlagName "execonly") (S.configConfigurationsFlags flags) of+ Just True -> True+ Just False -> False+ Nothing -> True+ isRelease :: S.ConfigFlags -> Bool isRelease flags = case lookup (FlagName "release") (S.configConfigurationsFlags flags) of@@ -106,7 +113,7 @@ "gitHash :: String\n" ++ if release then "gitHash = \"\"\n"- else "gitHash = \"-git:" ++ h ++ "\"\n"+ else "gitHash = \"git:" ++ h ++ "\"\n" -- Generate a module that contains the lib path for a freestanding Idris generateTargetModule verbosity dir targetDir = do@@ -176,7 +183,7 @@ let buildinfo = (emptyBuildInfo { cppOptions = ["-DVERSION="++hash] }) :: BuildInfo return (Just buildinfo, []) -idrisBuild _ flags _ local = do+idrisBuild _ flags _ local = unless (execOnly (configFlags local)) $ do buildStdLib buildRTS where@@ -199,7 +206,7 @@ -- ----------------------------------------------------------------------------- -- Copy/Install -idrisInstall verbosity copy pkg local = do+idrisInstall verbosity copy pkg local = unless (execOnly (configFlags local)) $ do installStdLib installRTS where
codegen/idris-c/Main.hs view
@@ -10,10 +10,12 @@ import System.Environment import System.Exit+import Control.Monad import Paths_idris data Opts = Opts { inputs :: [FilePath],+ interface :: Bool, output :: FilePath } showUsage = do putStrLn "Usage: idris-c <ibc-files> [-o <output-file>]"@@ -21,16 +23,19 @@ getOpts :: IO Opts getOpts = do xs <- getArgs- return $ process (Opts [] "a.out") xs+ return $ process (Opts [] False "a.out") xs where process opts ("-o":o:xs) = process (opts { output = o }) xs+ process opts ("--interface":xs) = process (opts { interface = True }) xs process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs process opts [] = opts c_main :: Opts -> Idris () c_main opts = do elabPrims loadInputs (inputs opts) Nothing- mainProg <- elabMain+ mainProg <- if interface opts + then liftM Just elabMain+ else return Nothing ir <- compile (Via "c") (output opts) mainProg runIO $ codegenC ir
codegen/idris-javascript/Main.hs view
@@ -32,7 +32,7 @@ jsMain opts = do elabPrims loadInputs (inputs opts) Nothing mainProg <- elabMain- ir <- compile (Via "javascript") (output opts) mainProg+ ir <- compile (Via "javascript") (output opts) (Just mainProg) runIO $ codegenJavaScript ir main :: IO ()
codegen/idris-node/Main.hs view
@@ -32,7 +32,7 @@ jsMain opts = do elabPrims loadInputs (inputs opts) Nothing mainProg <- elabMain- ir <- compile (Via "node") (output opts) mainProg+ ir <- compile (Via "node") (output opts) (Just mainProg) runIO $ codegenNode ir main :: IO ()
idris.cabal view
@@ -1,5 +1,5 @@ Name: idris-Version: 0.9.16+Version: 0.9.17 License: BSD3 License-file: LICENSE Author: Edwin Brady@@ -99,19 +99,25 @@ libs/base/base.ipkg libs/base/*.idr libs/base/Control/*.idr- libs/base/Control/Isomorphism/*.idr libs/base/Control/Monad/*.idr libs/base/Data/*.idr libs/base/Data/Vect/*.idr libs/base/Debug/*.idr- libs/base/Decidable/*.idr libs/base/Language/Reflection/*.idr libs/base/Makefile- libs/base/Network/*.idr libs/base/System/*.idr libs/base/System/Concurrency/*.idr libs/base/Syntax/*.idr + libs/contrib/contrib.ipkg+ libs/contrib/Makefile+ libs/contrib/Classes/*.idr+ libs/contrib/Control/*.idr+ libs/contrib/Control/Isomorphism/*.idr+ libs/contrib/Data/*.idr+ libs/contrib/Decidable/*.idr+ libs/contrib/Network/*.idr+ libs/contrib/System/Concurrency/*.idr libs/effects/Makefile libs/effects/effects.ipkg@@ -265,9 +271,9 @@ test/reg050/run test/reg050/*.idr test/reg050/expected- test/reg051/run- test/reg051/*.idr- test/reg051/expected+ test/reg051-disabled/run+ test/reg051-disabled/*.idr+ test/reg051-disabled/expected test/reg052/run test/reg052/*.idr test/reg052/expected@@ -286,6 +292,15 @@ test/reg057/run test/reg057/*.idr test/reg057/expected+ test/reg058/run+ test/reg058/*.idr+ test/reg058/expected+ test/reg059/run+ test/reg059/*.idr+ test/reg059/expected+ test/reg060/run+ test/reg060/*.idr+ test/reg060/expected test/basic001/run test/basic001/*.idr@@ -391,6 +406,10 @@ test/ffi005/*.idr test/ffi005/run test/ffi005/expected+ test/ffi006/*.idr+ test/ffi006/*.c+ test/ffi006/run+ test/ffi006/expected test/idrisdoc001/run test/idrisdoc001/expected@@ -455,6 +474,9 @@ test/interactive006/input test/interactive006/*.idr test/interactive006/expected+ test/interactive007/run+ test/interactive007/input+ test/interactive007/expected test/io001/run test/io001/*.idr@@ -491,6 +513,9 @@ test/proof004/run test/proof004/*.idr test/proof004/expected+ test/proof008/run+ test/proof008/*.idr+ test/proof008/expected test/quasiquote001/run test/quasiquote001/*.idr@@ -504,6 +529,9 @@ test/quasiquote004/run test/quasiquote004/*.idr test/quasiquote004/expected+ test/quasiquote005/run+ test/quasiquote005/*.idr+ test/quasiquote005/expected test/records001/run@@ -536,6 +564,9 @@ test/sugar005/*.idr test/sugar005/expected + test/tactics001/run+ test/tactics001/*.idr+ test/tactics001/expected test/totality001/run test/totality001/*.idr@@ -592,6 +623,20 @@ test/unique003/*.idr test/unique003/expected + test/docs001/run+ test/docs001/input+ test/docs001/*.idr+ test/docs001/expected+ test/docs002/run+ test/docs002/input+ test/docs002/*.idr+ test/docs002/expected+ test/docs003/run+ test/docs003/input+ test/docs003/*.idr+ test/docs003/expected++ source-repository head type: git location: git://github.com/idris-lang/Idris-dev.git@@ -628,6 +673,11 @@ Default: False manual: True +Flag execonly+ Description: Build executables only, skip the libraries and RTS+ Default: False+ manual: True+ Library hs-source-dirs: src Exposed-modules:@@ -679,7 +729,7 @@ , Idris.ErrReverse , Idris.Help , Idris.IBC- , Idris.IdeSlave+ , Idris.IdeMode , Idris.IdrisDoc , Idris.Imports , Idris.Inliner@@ -695,6 +745,7 @@ , Idris.ProofSearch , Idris.Prover , Idris.Providers+ , Idris.Reflection , Idris.REPL , Idris.REPLParser , Idris.Transforms@@ -708,6 +759,7 @@ , IRTS.CodegenC , IRTS.CodegenCommon , IRTS.CodegenJavaScript+ , IRTS.Exports , IRTS.JavaScript.AST , IRTS.Compiler , IRTS.Defunctionalise@@ -741,7 +793,7 @@ , base64-bytestring < 1.1 , binary >= 0.7 && < 0.8 , blaze-html >= 0.6.1.3 && < 0.8- , blaze-markup >= 0.5.2.1 && < 0.7.0.0+ , blaze-markup >= 0.5.2.1 && < 0.6.3.0 , bytestring < 0.11 , cheapskate < 0.2 , containers >= 0.5 && < 0.6@@ -751,7 +803,7 @@ , fingertree >= 0.1 && < 0.2 , haskeline >= 0.7 && < 0.8 , lens >= 4.1.1 && < 4.8- , mtl >= 2.2.1 && < 2.3+ , mtl >= 2.1 && < 2.3 , network < 2.7 , optparse-applicative >= 0.11 && < 0.12 , parsers >= 0.9 && < 0.13@@ -761,6 +813,7 @@ , text < 1.3 , time >= 1.4 && < 1.6 , transformers < 0.5+ , transformers-compat >= 0.3 , trifecta >= 1.1 && < 1.6 , uniplate >=1.6 && < 1.7 , unordered-containers < 0.3@@ -769,6 +822,7 @@ , vector-binary-instances < 0.3 , xml < 1.4 , zlib < 0.6+ , safe Extensions: MultiParamTypeClasses , DeriveFoldable , DeriveTraversable
jsrts/Runtime-common.js view
@@ -68,20 +68,18 @@ var res = fid; for(var i = 0; i < (arguments.length ? arguments.length : 1); ++i) {- while (res instanceof i$CON) {- i$valstack_top += 1;- i$valstack[i$valstack_top] = res;- i$valstack[i$valstack_top + 1] = arguments[i];- i$SLIDE(2);- i$valstack_top = i$valstack_base + 2;- i$CALL(_idris__123_APPLY0_125_,[oldbase])- while (i$callstack.length) {- var func = i$callstack.pop();- var args = i$callstack.pop();- func.apply(this,args);- }- res = i$ret;+ i$valstack_top += 1;+ i$valstack[i$valstack_top] = res;+ i$valstack[i$valstack_top + 1] = arguments[i];+ i$SLIDE(2);+ i$valstack_top = i$valstack_base + 2;+ i$CALL(_idris__123_APPLY0_125_,[oldbase])+ while (i$callstack.length) {+ var func = i$callstack.pop();+ var args = i$callstack.pop();+ func.apply(this,args); }+ res = i$ret; } i$callstack = i$vm.callstack;
libs/Makefile view
@@ -1,28 +1,33 @@ build: $(MAKE) -C prelude build $(MAKE) -C base build+ $(MAKE) -C contrib build $(MAKE) -C effects build install: $(MAKE) -C prelude install $(MAKE) -C base install+ $(MAKE) -C contrib install $(MAKE) -C effects install clean: $(MAKE) -C prelude clean $(MAKE) -C base clean+ $(MAKE) -C contrib clean $(MAKE) -C effects clean doc:- $(MAKE) -C prelude doc - $(MAKE) -C base doc - $(MAKE) -C effects doc + $(MAKE) -C prelude doc+ $(MAKE) -C base doc+ $(MAKE) -C contrib doc+ $(MAKE) -C effects doc doc_clean: $(MAKE) -C prelude doc_clean- $(MAKE) -C base doc_clean - $(MAKE) -C effects doc_clean + $(MAKE) -C base doc_clean+ $(MAKE) -C contrib doc_clean+ $(MAKE) -C effects doc_clean .PHONY: build install clean doc doc_clean
libs/base/Control/Arrow.idr view
@@ -95,7 +95,7 @@ instance Arrow a => Applicative (ArrowMonad a) where pure x = MkArrowMonad $ arrow $ \_ => x- (MkArrowMonad f) <$> (MkArrowMonad x) = MkArrowMonad $ f &&& x >>> arrow (uncurry id)+ (MkArrowMonad f) <*> (MkArrowMonad x) = MkArrowMonad $ f &&& x >>> arrow (uncurry id) instance ArrowApply a => Monad (ArrowMonad a) where (MkArrowMonad m) >>= f =
libs/base/Control/IOExcept.idr view
@@ -10,8 +10,8 @@ instance Applicative (IOExcept e) where pure x = ioM (pure (pure x))- (ioM f) <$> (ioM a) = ioM (do f' <- f; a' <- a- return (f' <$> a'))+ (ioM f) <*> (ioM a) = ioM (do f' <- f; a' <- a+ return (f' <*> a')) instance Monad (IOExcept e) where (ioM x) >>= k = ioM (do x' <- x;
− libs/base/Control/Isomorphism/Primitives.idr
@@ -1,35 +0,0 @@-module Control.Isomorphism.Primitives--import Control.Isomorphism-import Data.ZZ--%default total-%access public---- This module contains isomorphisms between convenient inductive types and--- Idris primitives. Because primitives lack a convenient structure, these--- arguments typically end with "really_believe_me". This is why they are in a--- separate module.--integerIsoZZ : Iso Integer ZZ-integerIsoZZ = MkIso toZZ fromZZ fromToZZ toFromZZ- where toZZ : Integer -> ZZ- toZZ n = cast n-- fromZZ : ZZ -> Integer- fromZZ n = cast n-- toFromZZ : (n : Integer) -> fromZZ (toZZ n) = n- toFromZZ n = really_believe_me {a = n=n} {b = fromZZ (toZZ n) = n} Refl-- fromToZZ : (n : ZZ) -> toZZ (fromZZ n) = n- fromToZZ n = really_believe_me {a = n=n} {b = toZZ (fromZZ n) = n} Refl---packUnpackIso : Iso (List Char) String-packUnpackIso = MkIso pack- unpack- (\str => really_believe_me {a = str=str} {b = pack (unpack str) = str} Refl)- (\cs => really_believe_me {a = cs=cs} {b = unpack (pack cs) = cs} Refl)--
libs/base/Control/Monad/Identity.idr view
@@ -9,7 +9,7 @@ instance Applicative Identity where pure x = Id x - (Id f) <$> (Id g) = Id (f g)+ (Id f) <*> (Id g) = Id (f g) instance Monad Identity where (Id x) >>= k = k x
libs/base/Control/Monad/RWS.idr view
@@ -21,7 +21,7 @@ instance (Monoid w, Monad m) => Applicative (RWST r w s m) where pure a = MkRWST $ \_,s => return (a, s, neutral)- (MkRWST f) <$> (MkRWST v) = MkRWST $ \r,s => do (a, s', w) <- v r s+ (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)
libs/base/Control/Monad/Reader.idr view
@@ -27,7 +27,7 @@ instance Applicative m => Applicative (ReaderT r m) where pure = liftReaderT . pure- (RD f) <$> (RD v) = RD $ \r => f r <$> v r+ (RD f) <*> (RD v) = RD $ \r => f r <*> v r instance Alternative m => Alternative (ReaderT r m) where empty = liftReaderT empty
libs/base/Control/Monad/State.idr view
@@ -6,7 +6,7 @@ %access public ||| A computation which runs in a context and produces an output-class Monad m => MonadState s (m : Type -> Type) where+class Monad m => MonadState s (m : Type -> Type) | m where ||| Get the context get : m s ||| Write a new context/output@@ -25,7 +25,7 @@ instance Monad f => Applicative (StateT s f) where pure x = ST (\st => pure (x, st)) - (ST f) <$> (ST a) = ST (\st => do (g, r) <- f st+ (ST f) <*> (ST a) = ST (\st => do (g, r) <- f st (b, t) <- a r return (g b, t))
libs/base/Control/Monad/Writer.idr view
@@ -25,7 +25,7 @@ instance (Monoid w, Applicative m) => Applicative (WriterT w m) where pure a = WR $ pure (a, neutral)- (WR f) <$> (WR v) = WR $ liftA2 merge f v where+ (WR f) <*> (WR v) = WR $ liftA2 merge f v where merge (fn, w) (a, w') = (fn a, w <+> w') instance (Monoid w, Alternative m) => Alternative (WriterT w m) where@@ -51,7 +51,8 @@ ||| Run an action in the Writer monad and transform the written output listens : MonadWriter w m => (w -> b) -> m a -> m (a, b)-listens f m = listens' f (listen m) where+listens {m} f act = listens' f (listen act) where+ listens' : (w -> b) -> m (a, w) -> m (a, b) listens' f' ma = do (a, w) <- ma return (a, f' w)
− libs/base/Data/BoundedList.idr
@@ -1,96 +0,0 @@-module Data.BoundedList--import Data.Fin--%access public-%default total--||| A list with an upper bound on its length.-data BoundedList : Nat -> Type -> Type where- Nil : BoundedList n a- (::) : a -> BoundedList n a -> BoundedList (S n) a--||| Compute the length of a list.-length : BoundedList n a -> Fin (S n)-length [] = FZ-length (x :: xs) = FS (length xs)------------------------------------------------------------------------------------- Indexing into bounded lists-----------------------------------------------------------------------------------index : Fin (S n) -> BoundedList n a -> Maybe a-index _ [] = Nothing-index FZ (x :: _) = Just x-index (FS f) (_ :: xs) = index f xs------------------------------------------------------------------------------------- Adjusting bounds-----------------------------------------------------------------------------------||| Loosen the bounds on a list's length.-weaken : BoundedList n a -> BoundedList (n + m) a-weaken [] = []-weaken (x :: xs) = x :: weaken xs------------------------------------------------------------------------------------- Conversions to and from list-----------------------------------------------------------------------------------take : (n : Nat) -> List a -> BoundedList n a-take _ [] = []-take Z _ = []-take (S n') (x :: xs) = x :: take n' xs--toList : BoundedList n a -> List a-toList [] = []-toList (x :: xs) = x :: Data.BoundedList.toList xs--fromList : (xs : List a) -> BoundedList (length xs) a-fromList [] = []-fromList (x :: xs) = x :: fromList xs------------------------------------------------------------------------------------- Building (bigger) bounded lists-----------------------------------------------------------------------------------replicate : (n : Nat) -> a -> BoundedList n a-replicate Z _ = []-replicate (S n) x = x :: replicate n x------------------------------------------------------------------------------------- Folds-----------------------------------------------------------------------------------instance Foldable (BoundedList n) where- foldr f e [] = e- foldr f e (x::xs) = f x (foldr f e xs)- foldl f e [] = e- foldl f e (x::xs) = foldl f (f e x) xs------------------------------------------------------------------------------------- Maps-----------------------------------------------------------------------------------instance Functor (BoundedList n) where- map f [] = []- map f (x :: xs) = f x :: map f xs------------------------------------------------------------------------------------- Misc-----------------------------------------------------------------------------------||| Extend a bounded list to the maximum size by padding on the left.-pad : BoundedList n a -> a -> BoundedList n a-pad {n=Z} [] _ = []-pad {n=S n'} [] padding = padding :: (pad {n=n'} [] padding)-pad {n=S n'} (x :: xs) padding = x :: pad {n=n'} xs padding-------------------------------------------------------------------------------------- Simple properties-----------------------------------------------------------------------------------zeroBoundIsEmpty : (xs : BoundedList 0 a) -> xs = the (BoundedList 0 a) []-zeroBoundIsEmpty [] = Refl-zeroBoundIsEmpty (_ :: _) impossible
− libs/base/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/base/Data/Erased.idr view
@@ -16,7 +16,7 @@ instance Applicative Erased where pure = Erase- (<$>) (Erase f) (Erase x) = Erase (f x)+ (<*>) (Erase f) (Erase x) = Erase (f x) instance Monad Erased where (>>=) (Erase x) f = f x
libs/base/Data/Fin.idr view
@@ -1,6 +1,7 @@ module Data.Fin %default total+%access public ||| Numbers strictly less than some bound. The name comes from "finite sets". |||@@ -144,18 +145,47 @@ %language ErrorReflection +||| Attempt to convert a reflected (fromInteger n) to a Nat+total private+getNat' : TT -> Maybe TT+getNat' `(fromInteger ~(TConst (BI c)) : Nat) = Just $ quote (the Nat (fromInteger c))+getNat' _ = Nothing++||| Attempt to convert a reflected (fromInteger n) to a Nat. Return+||| the original term on failure.+total private+getNat : TT -> TT+getNat tm = maybe tm id $ getNat' tm++total private+mkFinIntegerErr : TT -> TT -> List ErrorReportPart -> Maybe (List ErrorReportPart)+mkFinIntegerErr lit finSize subErr+ = Just [ TextPart "When using", TermPart lit+ , TextPart "as a literal for a"+ , TermPart `(Fin ~(getNat finSize))+ , SubReport subErr+ ] total finFromIntegerErrors : Err -> Maybe (List ErrorReportPart)+finFromIntegerErrors (CantUnify x tm `(IsJust (integerToFin ~(TConst c) ~m)) err xs y)+ = mkFinIntegerErr (TConst c) m+ [ TermPart (TConst c)+ , TextPart "is not strictly less than"+ , TermPart (getNat m)+ ]+finFromIntegerErrors (CantUnify x tm `(IsJust (integerToFin ~(P Bound n t) ~m)) err xs y)+ = mkFinIntegerErr (P Bound n t) m+ [ TextPart "Could not show that", TermPart (P Bound n t)+ , TextPart "is less than", TermPart (getNat m)+ , TextPart "because", TermPart (P Bound n t)+ , TextPart "is a bound variable instead of a constant"+ , TermPart `(Integer : Type)+ ] finFromIntegerErrors (CantUnify x tm `(IsJust (integerToFin ~n ~m)) err xs y)- = Just [ TextPart "When using", TermPart n- , TextPart "as a literal for a"- , TermPart `(Fin ~m)- , SubReport [ TextPart "Could not show that"- , TermPart n- , TextPart "is less than"- , TermPart m- ]- ]+ = mkFinIntegerErr n m+ [ TextPart "Could not show that" , TermPart n+ , TextPart "is less than" , TermPart (getNat m)+ ] finFromIntegerErrors _ = Nothing %error_handlers Data.Fin.fromInteger prf finFromIntegerErrors
− libs/base/Data/Fun.idr
@@ -1,17 +0,0 @@-module Data.Fun--import Data.Vect--%default total--||| Build an n-ary function type from a Vect of Types and a result type-Fun : Vect n Type -> Type -> Type-Fun [] r = r-Fun (t::ts) r = t -> Fun ts r--chain : {ts : Vect n Type} -> Fun [r] r' -> Fun ts r -> Fun ts r'-chain {ts = []} g r = g r-chain {ts = (_::_)} g f = \ x => chain g (f x)--target : {ts : Vect n Type} -> Fun ts r -> Type-target {r} _ = r
− libs/base/Data/Hash.idr
@@ -1,87 +0,0 @@-module Data.Hash--import Data.Vect--%access public-%default total--{- A general purpose Hashing library (not cryptographic)-- The core hash is djb2, which is very fast but does not have the best distribution- Source: http://www.cse.yorku.ca/~oz/hash.html-- The salted version and the magic salt are copied from Haskell's bloomfilter library- Source: https://hackage.haskell.org/package/bloomfilter-2.0.0.0/docs/src/Data-BloomFilter-Hash.html#Hashable--}--||| A type that can be hashed-class Hashable a where- saltedHash64 : a -> Bits64 -> Bits64 -- value to hash, salt, hash--||| Computes a non cryptographic hash-hash : Hashable a => a -> Bits64-hash x = saltedHash64 x 0x16fc397cf62f64d3--||| Given a user provided salt, computes a non cryptographic hash.-||| This version is meant to mitigate hash-flooding DoS attacks.-saltedHash : Hashable a => Bits64 -> a -> Bits64-saltedHash salt x = saltedHash64 x salt---||| Nth byte of a Bits64-private-byte : Bits64 -> Bits64 -> Bits64-byte n w = prim__lshrB64 (prim__andB64 mask w) offset- where offset = 8*n- mask = prim__shlB64 0xff (the Bits64 offset)--||| Modulo of an integer, downsized to a Bits64-private-mod64 : Integer -> Bits64-mod64 i = assert_total $ prim__truncBigInt_B64 (abs i `mod` 0xffffffffffffffff)--instance Hashable Bits64 where- saltedHash64 w salt = foldr (\b,acc => (acc `prim__shlB64` 10) + acc + b)- salt- [byte (fromInteger n) w | n <- [7,6..0]] -- djb2 hash function. Not meant for crypto--instance Hashable Integer where- saltedHash64 i = saltedHash64 (mod64 i)--instance Hashable () where- saltedHash64 _ salt = salt--instance Hashable Bool where- saltedHash64 True = saltedHash64 (the Bits64 1)- saltedHash64 False = saltedHash64 (the Bits64 0)--instance Hashable Int where- saltedHash64 w = saltedHash64 (prim__zextInt_B64 w)--instance Hashable Char where- saltedHash64 w = saltedHash64 (the Int (cast w))--instance Hashable Bits8 where- saltedHash64 w = saltedHash64 (prim__zextB8_B64 w)--instance Hashable Bits16 where- saltedHash64 w = saltedHash64 (prim__zextB16_B64 w)--instance Hashable Bits32 where- saltedHash64 w = saltedHash64 (prim__zextB32_B64 w)--instance Hashable a => Hashable (Maybe a) where- saltedHash64 Nothing salt = salt- saltedHash64 (Just k) salt = saltedHash64 k salt--instance (Hashable a, Hashable b) => Hashable (a, b) where- saltedHash64 (a,b) salt = saltedHash64 b (saltedHash64 a salt)--instance Hashable a => Hashable (List a) where- saltedHash64 l salt = foldr (\c,acc => saltedHash64 c acc) salt l--instance Hashable a => Hashable (Vect n a) where- saltedHash64 l salt = foldr (\c,acc => saltedHash64 c acc) salt l--instance Hashable String where- saltedHash64 s = saltedHash64 (unpack s)
− libs/base/Data/Heap.idr
@@ -1,189 +0,0 @@------------------------------------------------------------------------------------ Okasaki-style maxiphobic heaps. See the paper:--- ``Fun with binary heap trees'', Chris Okasaki, Fun of programming, 2003.-----------------------------------------------------------------------------------module Data.Heap--%default total-%access public--abstract data MaxiphobicHeap : Type -> Type where- Empty : MaxiphobicHeap a- Node : Nat -> MaxiphobicHeap a -> a -> MaxiphobicHeap a -> MaxiphobicHeap a------------------------------------------- ------------------------------------------ Syntactic tests-----------------------------------------------------------------------------------total isEmpty : MaxiphobicHeap a -> Bool-isEmpty Empty = True-isEmpty _ = False--total size : MaxiphobicHeap a -> Nat-size Empty = Z-size (Node s l e r) = s--isValidHeap : Ord a => MaxiphobicHeap a -> Bool-isValidHeap Empty = True-isValidHeap (Node s l e r) =- dominates e l && dominates e r && s == S (size l + size r)- where- dominates : Ord a => a -> MaxiphobicHeap a -> Bool- dominates e Empty = True- dominates e (Node s l e' r) = e' <= e------------------------------------------------------------------------------------- Basic heaps-----------------------------------------------------------------------------------total empty : MaxiphobicHeap a-empty = Empty--total singleton : a -> MaxiphobicHeap a-singleton e = Node 1 Empty e Empty------------------------------------------------------------------------------------- Inserting items and merging heaps-----------------------------------------------------------------------------------private orderBySize : MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a ->- (MaxiphobicHeap a, MaxiphobicHeap a, MaxiphobicHeap a)-orderBySize left centre right =- if size left == largest then- (left, centre, right)- else if size centre == largest then- (centre, left, right)- else- (right, left, centre)- where- largest : Nat- largest = maximum (size left) $ maximum (size centre) (size right)--%assert_total -- relies on orderBySize doing the right thing-merge : Ord a => MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a-merge Empty right = right-merge left Empty = left-merge (Node ls ll le lr) (Node rs rl re rr) =- if le < re then- let (largest, b, c) = orderBySize ll lr (Node rs rl re rr) in- Node mergedSize largest le (merge b c)- else- let (largest, b, c) = orderBySize rl rr (Node ls ll le lr) in- Node mergedSize largest re (merge b c)- where- mergedSize : Nat- mergedSize = ls + rs--insert : Ord a => a -> MaxiphobicHeap a -> MaxiphobicHeap a-insert e = merge $ singleton e------------------------------------------------------------------------------------- Heap operations-----------------------------------------------------------------------------------findMinimum : (h : MaxiphobicHeap a) -> (isEmpty h = False) -> a-findMinimum Empty Refl impossible-findMinimum (Node s l e r) p = e--deleteMinimum : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> MaxiphobicHeap a-deleteMinimum Empty Refl impossible-deleteMinimum (Node s l e r) p = merge l r------------------------------------------------------------------------------------- Conversions to and from lists (and a derived heap sorting algorithm)-----------------------------------------------------------------------------------toList : Ord a => MaxiphobicHeap a -> List a-toList Empty = []-toList (Node s l e r) = toList' (Node s l e r) Refl- where- %assert_total -- relies on deleteMinimum making heap smaller- toList' : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> List a- toList' heap p = findMinimum heap p :: (Heap.toList (deleteMinimum heap p))--fromList : Ord a => List a -> MaxiphobicHeap a-fromList = foldr insert empty--sort : Ord a => List a -> List a-sort = Heap.toList . Heap.fromList------------------------------------------------------------------------------------- Class instances-----------------------------------------------------------------------------------instance Show a => Show (MaxiphobicHeap a) where- show Empty = "Empty"- show (Node s l e r) = "Node (" ++ show l ++ " " ++ show e ++ " " ++ show r ++ ")"--instance Eq a => Eq (MaxiphobicHeap a) where- Empty == Empty = True- (Node ls ll le lr) == (Node rs rl re rr) =- ls == rs && ll == rl && le == re && lr == rr- _ == _ = False--instance Ord a => Semigroup (MaxiphobicHeap a) where- (<+>) = merge--instance Ord a => Monoid (MaxiphobicHeap a) where- neutral = empty--instance Ord a => JoinSemilattice (MaxiphobicHeap a) where- join = merge------------------------------------------------------------------------------------- Properties-----------------------------------------------------------------------------------total absurdBoolDischarge : False = True -> Void-absurdBoolDischarge p = replace {P = disjointTy} p ()- where- total disjointTy : Bool -> Type- disjointTy False = ()- disjointTy True = Void--total isEmptySizeZero : (h : MaxiphobicHeap a) -> (isEmpty h = True) -> size h = Z-isEmptySizeZero Empty p = Refl-isEmptySizeZero (Node s l e r) p = ?isEmptySizeZeroNodeAbsurd--total emptyHeapValid : Ord a => isValidHeap empty = True-emptyHeapValid = Refl--total singletonHeapValid : Ord a => (e : a) -> isValidHeap $ singleton e = True-singletonHeapValid e = Refl--{--total mergePreservesValidHeaps : Ord a => (left : MaxiphobicHeap a) ->- (right : MaxiphobicHeap a) -> (leftValid : isValidHeap left = True) ->- (rightValid : isValidHeap right = True) -> isValidHeap $ merge left right = True-mergePreservesValidHeaps Empty Empty lp rp = Refl-mergePreservesValidHeaps Empty (Node rs rl re rr) lp rp = rp-mergePreservesValidHeaps (Node ls ll le lr) Empty lp rp = lp-mergePreservesValidHeaps (Node ls ll le lr) (Node rs rl re rr) lp rp =- ?mergePreservesValidHeapsBody--}------------------------------------------------------------------------------------- Proofs-----------------------------------------------------------------------------------isEmptySizeZeroNodeAbsurd = proof {- intros;- refine void;- refine absurdBoolDischarge;- exact p;-}------------------------------------------------------------------------------------- Debug-----------------------------------------------------------------------------------{- XXX: poor performance when compiled, diverges when used in the REPL, but it- does seem to work correctly!-main : IO ()-main = do- _ <- print $ main.sort [10, 3, 7, 2, 9, 1, 8, 0, 6, 4, 5]- _ <- print $ main.sort ["orange", "apple", "pear", "lime", "durian"]- _ <- print $ main.sort [("jim", 19, "cs"), ("alice", 20, "english"), ("bob", 50, "engineering")]- return ()--}
− libs/base/Data/Matrix.idr
@@ -1,256 +0,0 @@-module Data.Matrix--import Data.Complex-import Data.ZZ-import Data.Fin-import Data.Vect--%default total--infixr 2 <.> -- vector inner product-infixr 2 >< -- vector outer product-infixr 2 <<>> -- matrix commutator-infixr 2 >><< -- matrix anticommutator-infixl 3 <\> -- row times a matrix-infixr 4 </> -- matrix times a column-infixr 5 <> -- matrix multiplication -infixr 7 \&\ -- vector tensor product-infixr 7 <&> -- matrix tensor product---------------------------------------------------------------------------- Vectors as members of algebraic classes--------------------------------------------------------------------------instance Semigroup a => Semigroup (Vect n a) where- (<+>) v w = zipWith (<+>) v w--instance Monoid a => Monoid (Vect n a) where- neutral {n} = replicate n neutral- -instance Group a => Group (Vect n a) where- inverse = map inverse--instance AbelianGroup a => AbelianGroup (Vect n a) where {}--instance Ring a => Ring (Vect n a) where- (<*>) v w = zipWith (<*>) v w--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 RingWithUnity a => Module a (Vect n a) where- (<#>) r v = map (r <*>) v--instance RingWithUnity a => Module a (Vect n (Vect l a)) where- (<#>) r m = map (r <#>) m--- should be Module a b => Module a (Vect n b), but results in 'overlapping instance'---------------------------------------------------------------------------- (Ring) Vector functions--------------------------------------------------------------------------||| Inner product of ring vectors-(<.>) : Ring a => Vect n a -> Vect n a -> a-(<.>) w v = foldr (<+>) neutral (zipWith (<*>) w v)--||| Tensor multiply (⊗) ring vectors-(\&\) : Ring a => Vect n a -> Vect m a -> Vect (n * m) a-(\&\) {n} {m} v w = zipWith (<*>) (oextend m v) (orep n w) where- orep : (n : Nat) -> Vect m a -> Vect (n * m) a- orep n v = concat $ replicate n v- oextend : (n : Nat) -> Vect k a -> Vect (k * n) a- oextend n w = concat $ map (replicate n) w--||| Standard basis vector with one nonzero entry, ring data type and vector-length unfixed-basis : RingWithUnity a => {d : Nat} -> (Fin d) -> Vect d a-basis i = replaceAt i unity $ neutral---------------------------------------------------------------------------- Matrix functions--------------------------------------------------------------------------||| Matrix with n rows and m columns-Matrix : Nat -> Nat -> Type -> Type-Matrix n m a = Vect n (Vect m a)--||| Gets the specified column of a matrix. For rows use the vector function 'index'-getCol : Fin m -> Matrix n m a -> Vect n a-getCol fm q = map (index fm) q--||| Deletes the specified column of a matrix. For rows use the vector function 'deleteAt'-deleteCol : Fin (S m) -> Matrix n (S m) a -> Matrix n m a-deleteCol f m = map (deleteAt f) m--||| Matrix element at specified row and column indices-indices : Fin n -> Fin m -> Matrix n m a -> a-indices f1 f2 m = index f2 (index f1 m)--||| Matrix times a column vector-(</>) : Ring a => Matrix n m a -> Vect m a -> Vect n a-(</>) m v = map (v <.>) m--||| Matrix times a row vector-(<\>) : Ring a => Vect n a -> Matrix n m a -> Vect m a-(<\>) r m = map (r <.>) $ transpose m--||| Matrix multiplication-(<>) : Ring a => Matrix n k a -> - Matrix k m a -> - Matrix n m a-(<>) m1 m2 = map (<\> m2) m1--||| Tensor multiply (⊗) for ring matrices-(<&>) : Ring a => Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) (w1 * w2) a-(<&>) m1 m2 = zipWith (\&\) (stepOne m1 m2) (stepTwo m1 m2) where- stepOne : Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) w1 a- stepOne {h2} m1 m2 = concat $ map (replicate h2) m1- stepTwo : Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) w2 a- stepTwo {h1} m1 m2 = concat $ (Vect.replicate h1) m2--||| Cast a vector from a standard Vect to a proper n x 1 matrix -col : Vect n a -> Matrix n 1 a-col v = map (\x => [x]) v--||| Cast a row from a standard Vect to a proper 1 x n matrix -row : Vect n a -> Matrix 1 n a-row r = [r]--||| Outer product between ring vectors-(><) : Ring a => Vect n a -> Vect m a -> Matrix n m a-(><) x y = (col x) <> (row y)--||| All finite numbers up to the given bound-allN : (n : Nat) -> Vect n (Fin n)-allN Z = Nil-allN (S n) = FZ :: (map FS $ allN n)--||| Identity matrix-Id : RingWithUnity a => {d : Nat} -> Matrix d d a-Id {d} = map (\n => basis n) $ allN d--||| Matrix commutator-(<<>>) : Ring a => Matrix n n a -> Matrix n n a -> Matrix n n a-(<<>>) m1 m2 = (m1 <> m2) <-> (m2 <> m1)--||| Matrix anti-commutator-(>><<) : Ring a => Matrix n n a -> Matrix n n a -> Matrix n n a-(>><<) m1 m2 = (m1 <> m2) <+> (m2 <> m1)---------------------------------------------------------------------------- Matrix Algebra Properties---------------------------------------------------------------------------- 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 VerifiedSemigroup Nat where- semigroupOpIsAssociative = plusAssociative--instance VerifiedMonoid Nat where- monoidNeutralIsNeutralL = plusZeroRightNeutral- monoidNeutralIsNeutralR = plusZeroLeftNeutral---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/base/Data/Morphisms.idr view
@@ -25,7 +25,7 @@ instance Applicative (Morphism r) where pure a = Mor $ const a- (Mor f) <$> (Mor a) = Mor $ \r => f r $ a r+ (Mor f) <*> (Mor a) = Mor $ \r => f r $ a r instance Monad (Morphism r) where (Mor h) >>= f = Mor $ \r => applyMor (f $ h r) r
− libs/base/Data/Rel.idr
@@ -1,12 +0,0 @@-module Data.Rel--import Data.Fun---||| Build an n-ary relation type from a Vect of Types-Rel : Vect n Type -> Type-Rel ts = Fun ts Type--liftRel : (ts : Vect n Type) -> (p : Rel ts) -> (Type -> Type) -> Type-liftRel [] p f = f p-liftRel (t :: ts) p f = (x : t) -> liftRel ts (p x) f
− libs/base/Data/Sign.idr
@@ -1,8 +0,0 @@-module Data.Sign--||| A representation of signs for signed datatypes such as `ZZ`-data Sign = Plus | Minus--||| Discover the sign of some type-class Signed t where- total sign : t -> Sign
− libs/base/Data/SortedMap.idr
@@ -1,237 +0,0 @@-module Data.SortedMap---- 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--branch4 :- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v ->- Tree (S (S n)) k v-branch4 a b c d e f g =- Branch2 (Branch2 a b c) d (Branch2 e f g)--branch5 :- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v ->- Tree (S (S n)) k v-branch5 a b c d e f g h i =- Branch2 (Branch2 a b c) d (Branch3 e f g h i)--branch6 :- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v ->- Tree (S (S n)) k v-branch6 a b c d e f g h i j k =- Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)--branch7 :- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v -> k ->- Tree n k v ->- Tree (S (S n)) k v-branch7 a b c d e f g h i j k l m =- Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)--merge1 : Tree n k v -> k -> Tree (S n) k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v-merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i-merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k-merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k-merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m--merge2 : Tree (S n) k v -> k -> Tree n k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v-merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i-merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k-merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k-merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m--merge3 : Tree (S n) k v -> k -> Tree (S n) k v -> k -> Tree n k v -> Tree (S (S n)) k v-merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i-merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k-merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k-merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m--treeLookup : Ord k => k -> Tree n k v -> Maybe v-treeLookup k (Leaf k' v) =- if k == k' then- Just v- else- Nothing-treeLookup k (Branch2 t1 k' t2) =- if k <= k' then- treeLookup k t1- else- treeLookup k t2-treeLookup k (Branch3 t1 k1 t2 k2 t3) =- if k <= k1 then- treeLookup k t1- else if k <= k2 then- treeLookup k t2- else- treeLookup k t3--treeInsert' : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree n k v, k, Tree n k v)-treeInsert' k v (Leaf k' v') =- case compare k k' of- LT => Right (Leaf k v, k, Leaf k' v')- EQ => Left (Leaf k v)- GT => Right (Leaf k' v', k', Leaf k v)-treeInsert' k v (Branch2 t1 k' t2) =- if k <= k' then- case treeInsert' k v t1 of- Left t1' => Left (Branch2 t1' k' t2)- Right (a, b, c) => Left (Branch3 a b c k' t2)- else- case treeInsert' k v t2 of- Left t2' => Left (Branch2 t1 k' t2')- Right (a, b, c) => Left (Branch3 t1 k' a b c)-treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =- if k <= k1 then- case treeInsert' k v t1 of- Left t1' => Left (Branch3 t1' k1 t2 k2 t3)- Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3)- else- if k <= k2 then- case treeInsert' k v t2 of- Left t2' => Left (Branch3 t1 k1 t2' k2 t3)- Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3)- else- case treeInsert' k v t3 of- Left t3' => Left (Branch3 t1 k1 t2 k2 t3')- Right (a, b, c) => Right (Branch2 t1 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 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--treeDelete : Ord k => k -> Tree n k v -> Either (Tree n k v) (delType n k v)-treeDelete k (Leaf k' v) =- if k == k' then- Right ()- else- Left (Leaf k' v)-treeDelete {n=S Z} k (Branch2 t1 k' t2) =- if k <= k' then- case treeDelete k t1 of- Left t1' => Left (Branch2 t1' k' t2)- Right () => Right t2- else- case treeDelete k t2 of- Left t2' => Left (Branch2 t1 k' t2')- Right () => Right t1-treeDelete {n=S Z} k (Branch3 t1 k1 t2 k2 t3) =- if k <= k1 then- case treeDelete k t1 of- Left t1' => Left (Branch3 t1' k1 t2 k2 t3)- Right () => Left (Branch2 t2 k2 t3)- else if k <= k2 then- case treeDelete k t2 of- Left t2' => Left (Branch3 t1 k1 t2' k2 t3)- Right () => Left (Branch2 t1 k1 t3)- else- case treeDelete k t3 of- Left t3' => Left (Branch3 t1 k1 t2 k2 t3')- Right () => Left (Branch2 t1 k1 t2)-treeDelete {n=S (S _)} k (Branch2 t1 k' t2) =- if k <= k' then- case treeDelete k t1 of- Left t1' => Left (Branch2 t1' k' t2)- Right t1' =>- case t2 of- Branch2 a b c => Right (Branch3 t1' k' a b c)- Branch3 a b c d e => Left (branch4 t1' k' a b c d e)- else- case treeDelete k t2 of- Left t2' => Left (Branch2 t1 k' t2')- Right t2' =>- case t1 of- Branch2 a b c => Right (Branch3 a b c k' t2')- Branch3 a b c d e => Left (branch4 a b c d e k' t2')-treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) =- if k <= k1 then- case treeDelete k t1 of- Left t1' => Left (Branch3 t1' k1 t2 k2 t3)- Right t1' => Left (merge1 t1' k1 t2 k2 t3)- else if k <= k2 then- case treeDelete k t2 of- Left t2' => Left (Branch3 t1 k1 t2' k2 t3)- Right t2' => Left (merge2 t1 k1 t2' k2 t3)- else- case treeDelete k t3 of- Left t3' => Left (Branch3 t1 k1 t2 k2 t3')- Right t3' => Left (merge3 t1 k1 t2 k2 t3')--treeToList : Tree n k v -> List (k, v)-treeToList = treeToList' (:: [])- where- treeToList' : ((k, v) -> List (k, v)) -> Tree n k v -> 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--data SortedMap : Type -> Type -> Type where- Empty : SortedMap k v- M : (n:Nat) -> Tree n k v -> SortedMap k v--empty : SortedMap k v-empty = Empty--lookup : Ord k => k -> SortedMap k v -> Maybe v-lookup _ Empty = Nothing-lookup k (M _ t) = treeLookup k t--insert : Ord k => k -> v -> SortedMap k v -> SortedMap k v-insert k v Empty = M 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-delete _ Empty = Empty-delete k (M Z t) =- case treeDelete k t of- Left t' => (M _ t')- Right () => Empty-delete k (M (S _) t) =- case treeDelete k t of- Left t' => (M _ t')- Right t' => (M _ t')--fromList : Ord k => List (k, v) -> SortedMap k v-fromList l = foldl (flip (uncurry insert)) empty l--toList : 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)--instance Functor (SortedMap k) where- map _ Empty = Empty- map f (M n t) = M _ (map f t)
libs/base/Data/VectType.idr view
@@ -1,4 +1,4 @@-module Data.VectType +module Data.VectType import Data.Fin @@ -6,7 +6,7 @@ %default total namespace Vect {- + infixr 7 :: %elim data Vect : Nat -> Type -> Type where@@ -529,8 +529,10 @@ instance Applicative (Vect k) where pure = replicate _ - fs <$> vs = zipWith apply fs vs+ fs <*> vs = zipWith apply fs vs +||| This monad is different from the List monad, (>>=)+||| uses the diagonal. instance Monad (Vect n) where m >>= f = diag (map f m) @@ -539,7 +541,7 @@ traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |] ----------------------------------------------------------------------------------- Show +-- Show -------------------------------------------------------------------------------- instance Show a => Show (Vect n a) where@@ -595,4 +597,3 @@ -- For the primitives, we have to cheat because we don't have access to their -- internal implementations.-
− libs/base/Data/ZZ.idr
@@ -1,153 +0,0 @@-module Data.ZZ--import Decidable.Equality-import Data.Sign--%default total-%access public---||| An integer is either a positive `Nat` or the negated successor of a `Nat`.-|||-||| For example, 3 is `Pos 3` and -2 is `NegS 1`. Zero is arbitrarily chosen-||| to be positive.-|||-data ZZ = Pos Nat | NegS Nat--instance Signed ZZ where- sign (Pos _) = Plus- sign (NegS _) = Minus--||| Take the absolute value of a `ZZ`-absZ : ZZ -> Nat-absZ (Pos n) = n-absZ (NegS n) = S n--instance Show ZZ where- show (Pos n) = show n- show (NegS n) = "-" ++ show (S n)--instance Neg ZZ where- negate (Pos Z) = Pos Z- negate (Pos (S n)) = NegS n- negate (NegS n) = Pos (S n)--negNat : Nat -> ZZ-negNat Z = Pos Z-negNat (S n) = NegS n---||| Construct a `ZZ` as the difference of two `Nat`s-minusNatZ : Nat -> Nat -> ZZ-minusNatZ n Z = Pos n-minusNatZ Z (S m) = NegS m-minusNatZ (S n) (S m) = minusNatZ n m--||| Add two `ZZ`s. Consider using `(+) {a=ZZ}`.-plusZ : ZZ -> ZZ -> ZZ-plusZ (Pos n) (Pos m) = Pos (n + m)-plusZ (NegS n) (NegS m) = NegS (S (n + m))-plusZ (Pos n) (NegS m) = minusNatZ n (S m)-plusZ (NegS n) (Pos m) = minusNatZ m (S n)--||| Subtract two `ZZ`s. Consider using `(-) {a=ZZ}`.-subZ : ZZ -> ZZ -> ZZ-subZ n m = plusZ n (negate m)--instance Eq ZZ where- (Pos n) == (Pos m) = n == m- (NegS n) == (NegS m) = n == m- _ == _ = False---instance Ord ZZ where- compare (Pos n) (Pos m) = compare n m- compare (NegS n) (NegS m) = compare m n- compare (Pos _) (NegS _) = GT- compare (NegS _) (Pos _) = LT--||| Multiply two `ZZ`s. Consider using `(*) {a=ZZ}`.-multZ : ZZ -> ZZ -> ZZ-multZ (Pos n) (Pos m) = Pos $ n * m-multZ (NegS n) (NegS m) = Pos $ (S n) * (S m)-multZ (NegS n) (Pos m) = negNat $ (S n) * m-multZ (Pos n) (NegS m) = negNat $ n * (S m)--||| Convert an `Integer` to an inductive representation.-fromInt : Integer -> ZZ-fromInt n = if n < 0- then NegS $ fromInteger {a=Nat} ((-n) - 1)- else Pos $ fromInteger {a=Nat} n--instance Cast Nat ZZ where- cast n = Pos n--instance Num ZZ where- (+) = plusZ- (-) = subZ- (*) = multZ- abs = cast . absZ- fromInteger = fromInt--instance Cast ZZ Integer where- cast (Pos n) = cast n- cast (NegS n) = (-1) * (cast n + 1)--instance Cast Integer ZZ where- cast = fromInteger-------------------------------------------------------------------------------------- Properties-----------------------------------------------------------------------------------natPlusZPlus : (n : Nat) -> (m : Nat) -> (x : Nat)- -> n + m = x -> (Pos n) + (Pos m) = Pos x-natPlusZPlus n m x h = cong h--natMultZMult : (n : Nat) -> (m : Nat) -> (x : Nat)- -> n * m = x -> (Pos n) * (Pos m) = Pos x-natMultZMult n m x h = cong h--doubleNegElim : (z : ZZ) -> negate (negate z) = z-doubleNegElim (Pos Z) = Refl-doubleNegElim (Pos (S n)) = Refl-doubleNegElim (NegS Z) = Refl-doubleNegElim (NegS (S n)) = Refl---- Injectivity-posInjective : Pos n = Pos m -> n = m-posInjective Refl = Refl--negSInjective : NegS n = NegS m -> n = m-negSInjective Refl = Refl--posNotNeg : Pos n = NegS m -> Void-posNotNeg Refl impossible---- Decidable equality-instance DecEq ZZ where- decEq (Pos n) (NegS m) = No posNotNeg- decEq (NegS n) (Pos m) = No $ negEqSym posNotNeg- decEq (Pos n) (Pos m) with (decEq n m)- | Yes p = Yes $ cong p- | No p = No $ \h => p $ posInjective h- decEq (NegS n) (NegS m) with (decEq n m)- | Yes p = Yes $ cong p- | No p = No $ \h => p $ negSInjective h---- Plus-plusZeroLeftNeutralZ : (right : ZZ) -> 0 + right = right-plusZeroLeftNeutralZ (Pos n) = Refl-plusZeroLeftNeutralZ (NegS n) = Refl--plusZeroRightNeutralZ : (left : ZZ) -> left + 0 = left-plusZeroRightNeutralZ (Pos n) = cong $ plusZeroRightNeutral n-plusZeroRightNeutralZ (NegS n) = Refl--plusCommutativeZ : (left : ZZ) -> (right : ZZ) -> (left + right = right + left)-plusCommutativeZ (Pos n) (Pos m) = cong $ plusCommutative n m-plusCommutativeZ (Pos n) (NegS m) = Refl-plusCommutativeZ (NegS n) (Pos m) = Refl-plusCommutativeZ (NegS n) (NegS m) = cong {f=NegS} $ cong {f=S} $ plusCommutative n m-
libs/base/Debug/Error.idr view
@@ -12,7 +12,7 @@ (message : String) -> a error {loc = FileLoc filename (line, col) _} message =- believe_me . unsafePerformIO $+ believe_me . unsafePerformIO $ do let place = filename ++ " line " ++ show line ++ " column " ++ show col let message' = place ++ ": " ++ message putStrLn message'
libs/base/Debug/Trace.idr view
@@ -4,6 +4,6 @@ ||| @ msg what to print ||| @ result the final result trace : (msg : String) -> (result : a) -> a-trace x val = unsafePerformIO (do putStrLn x; return val)+trace x val = unsafePerformIO {ffi=FFI_C} (do putStrLn x; return val)
− libs/base/Decidable/Decidable.idr
@@ -1,23 +0,0 @@-module Decidable.Decidable--import Data.Rel-import Data.Fun--%access public------------------------------------------------------------------------------------- Typeclass for decidable n-ary Relations------------------------------------------------------------------------------------- Note: Instance resolution for Decidable is likely to not work in the REPL--- at the moment.-class Decidable (ts : Vect k Type) (p : Rel ts) where- total decide : liftRel ts p Dec---- 'No such variable {k506}'---decision : Decidable ts p => (ts : Vect k Type) -> (p : Rel ts) -> liftRel ts p Dec---decision ts p = decide {ts} {p}--using (a : Type, x : a)- data Given : Dec a -> Type where- Always : Given (Yes x)
− libs/base/Decidable/Order.idr
@@ -1,156 +0,0 @@-module Decidable.Order--import Decidable.Decidable-import Decidable.Equality-import Data.Fin-import Data.Fun-import Data.Rel--%access public------------------------------------------------------------------------------------- Utility Lemmas---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Preorders, Posets, total Orders, Equivalencies, Congruencies-----------------------------------------------------------------------------------class Preorder t (po : t -> t -> Type) where- total transitive : (a : t) -> (b : t) -> (c : t) -> po a b -> po b c -> po a c- total reflexive : (a : t) -> po a a--class (Preorder t po) => Poset t (po : t -> t -> Type) where- total antisymmetric : (a : t) -> (b : t) -> po a b -> po b a -> a = b--class (Poset t to) => Ordered t (to : t -> t -> Type) where- total order : (a : t) -> (b : t) -> Either (to a b) (to b a)--class (Preorder t eq) => Equivalence t (eq : t -> t -> Type) where- total symmetric : (a : t) -> (b : t) -> eq a b -> eq b a--class (Equivalence t eq) => Congruence t (f : t -> t) (eq : t -> t -> Type) where- total congruent : (a : t) -> - (b : t) -> - eq a b -> - eq (f a) (f b)--minimum : (Ordered t to) => t -> t -> t-minimum x y with (order x y)- | Left _ = x- | Right _ = y--maximum : (Ordered t to) => t -> t -> t-maximum x y with (order x y)- | Left _ = y- | Right _ = x------------------------------------------------------------------------------------- Syntactic equivalence (=)-----------------------------------------------------------------------------------instance Preorder t ((=) {A = t} {B = t}) where- transitive a b c = trans {a = a} {b = b} {c = c}- reflexive a = Refl--instance Equivalence t ((=) {A = t} {B = t}) where- symmetric a b prf = sym prf--instance Congruence t f ((=) {A = t} {B = t}) where- congruent a b = cong {a = a} {b = b} {f = f}------------------------------------------------------------------------------------- Natural numbers-----------------------------------------------------------------------------------total LTEIsTransitive : (m : Nat) -> (n : Nat) -> (o : Nat) ->- LTE m n -> LTE n o ->- LTE m o-LTEIsTransitive Z n o LTEZero nlteo = LTEZero-LTEIsTransitive (S m) (S n) (S o) (LTESucc mlten) (LTESucc nlteo) = LTESucc (LTEIsTransitive m n o mlten nlteo)--total LTEIsReflexive : (n : Nat) -> LTE n n-LTEIsReflexive Z = LTEZero-LTEIsReflexive (S n) = LTESucc (LTEIsReflexive n)--instance Preorder Nat LTE where- transitive = LTEIsTransitive- reflexive = LTEIsReflexive--total LTEIsAntisymmetric : (m : Nat) -> (n : Nat) ->- LTE m n -> LTE n m -> m = n-LTEIsAntisymmetric Z Z LTEZero LTEZero = Refl-LTEIsAntisymmetric (S n) (S m) (LTESucc mLTEn) (LTESucc nLTEm) with (LTEIsAntisymmetric n m mLTEn nLTEm)- LTEIsAntisymmetric (S n) (S n) (LTESucc mLTEn) (LTESucc nLTEm) | Refl = Refl ---instance Poset Nat LTE where- antisymmetric = LTEIsAntisymmetric--total zeroNeverGreater : {n : Nat} -> LTE (S n) Z -> Void-zeroNeverGreater {n} LTEZero impossible-zeroNeverGreater {n} (LTESucc _) impossible--total zeroAlwaysSmaller : {n : Nat} -> LTE Z n-zeroAlwaysSmaller = LTEZero--total ltesuccinjective : {n : Nat} -> {m : Nat} -> (LTE n m -> Void) -> LTE (S n) (S m) -> Void-ltesuccinjective {n} {m} disprf (LTESucc nLTEm) = void (disprf nLTEm)-ltesuccinjective {n} {m} disprf LTEZero impossible---total decideLTE : (n : Nat) -> (m : Nat) -> Dec (LTE n m)-decideLTE Z y = Yes LTEZero-decideLTE (S x) Z = No zeroNeverGreater-decideLTE (S x) (S y) with (decEq (S x) (S y))- | Yes eq = rewrite eq in Yes (reflexive x)- | No _ with (decideLTE x y)- | Yes nLTEm = Yes (LTESucc nLTEm)- | No nGTm = No (ltesuccinjective nGTm)--instance Decidable [Nat,Nat] LTE where- decide = decideLTE--total-lte : (m : Nat) -> (n : Nat) -> Dec (LTE m n)-lte m n = decide {ts = [Nat,Nat]} {p = LTE} m n--total-shift : (m : Nat) -> (n : Nat) -> LTE m n -> LTE (S m) (S n)-shift m n mLTEn = LTESucc mLTEn- -instance Ordered Nat LTE where- order Z n = Left LTEZero- order m Z = Right LTEZero- order (S k) (S j) with (order k j)- order (S k) (S j) | Left prf = Left (shift k j prf)- order (S k) (S j) | Right prf = Right (shift j k prf)----------------------------------------------------------------------------------------- Finite numbers-------------------------------------------------------------------------------------using (k : Nat)- data FinLTE : Fin k -> Fin k -> Type where- FromNatPrf : {m : Fin k} -> {n : Fin k} -> LTE (finToNat m) (finToNat n) -> FinLTE m n-- instance Preorder (Fin k) FinLTE where- transitive m n o (FromNatPrf p1) (FromNatPrf p2) = - FromNatPrf (LTEIsTransitive (finToNat m) (finToNat n) (finToNat o) p1 p2)- reflexive n = FromNatPrf (LTEIsReflexive (finToNat n))-- instance Poset (Fin k) FinLTE where- antisymmetric m n (FromNatPrf p1) (FromNatPrf p2) =- finToNatInjective m n (LTEIsAntisymmetric (finToNat m) (finToNat n) p1 p2)- - instance Decidable [Fin k, Fin k] FinLTE where- decide m n with (decideLTE (finToNat m) (finToNat n))- | Yes prf = Yes (FromNatPrf prf)- | No disprf = No (\ (FromNatPrf prf) => disprf prf)-- instance Ordered (Fin k) FinLTE where- order m n =- either (Left . FromNatPrf) - (Right . FromNatPrf)- (order (finToNat m) (finToNat n))-
libs/base/Language/Reflection/Utils.idr view
@@ -270,8 +270,10 @@ show (NoTypeDecl n) = "NoTypeDecl " ++ show n show (NotInjective tm tm' x) = "NotInjective " ++ show tm ++ " " ++ show tm' show (CantResolve tm) = "CantResolve " ++ show tm+ show (InvalidTCArg n tm) = "InvalidTCName " ++ show n ++ " (" ++ show tm ++ ")" show (CantResolveAlts xs) = "CantResolveAlts " ++ show xs show (IncompleteTerm tm) = "IncompleteTerm " ++ show tm+ show (NoEliminator s tm) = "NoEliminator " ++ show s ++ " " ++ show tm show UniverseError = "UniverseError" show ProgramLineComment = "ProgramLineComment" show (Inaccessible n) = "Inaccessible " ++ show n
− libs/base/Network/Cgi.idr
@@ -1,143 +0,0 @@-module Network.Cgi--import System--%default total--public-Vars : Type-Vars = List (String, String)--record CGIInfo : Type where- CGISt : (GET : Vars) ->- (POST : Vars) ->- (Cookies : Vars) ->- (UserAgent : String) ->- (Headers : String) ->- (Output : String) -> CGIInfo--add_Headers : String -> CGIInfo -> CGIInfo-add_Headers str st = record { Headers = Headers st ++ str } st--add_Output : String -> CGIInfo -> CGIInfo-add_Output str st = record { Output = Output st ++ str } st--abstract-data CGI : Type -> Type where- MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a--getAction : CGI a -> CGIInfo -> IO (a, CGIInfo)-getAction (MkCGI act) = act--instance Functor CGI where- map f (MkCGI c) = MkCGI (\s => do (a, i) <- c s- return (f a, i))--instance Applicative CGI where- pure v = MkCGI (\s => return (v, s))-- (MkCGI a) <$> (MkCGI b) = MkCGI (\s => do (f, i) <- a s- (c, j) <- b i- return (f c, j))--instance Monad CGI where {- (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s- getAction (k (fst v)) (snd v))-}--setInfo : CGIInfo -> CGI ()-setInfo i = MkCGI (\s => return ((), i))--getInfo : CGI CGIInfo-getInfo = MkCGI (\s => return (s, s))--abstract-lift : IO a -> CGI a-lift op = MkCGI (\st => do { x <- op- return (x, st) } )--abstract-output : String -> CGI ()-output s = do i <- getInfo- setInfo (add_Output s i)--abstract-queryVars : CGI Vars-queryVars = do i <- getInfo- return (GET i)--abstract-postVars : CGI Vars-postVars = do i <- getInfo- return (POST i)--abstract-cookieVars : CGI Vars-cookieVars = do i <- getInfo- return (Cookies i)--abstract-queryVar : String -> CGI (Maybe String)-queryVar x = do vs <- queryVars- return (lookup x vs)--getOutput : CGI String-getOutput = do i <- getInfo- return (Output i)--getHeaders : CGI String-getHeaders = do i <- getInfo- return (Headers i)--abstract-flushHeaders : CGI ()-flushHeaders = do o <- getHeaders- lift (putStrLn o)--abstract-flush : CGI ()-flush = do o <- getOutput- lift (putStr o)--getVars : List Char -> String -> List (String, String)-getVars seps query = mapMaybe readVar (split (\x => elem x seps) query)- where- readVar : String -> Maybe (String, String)- readVar xs with (split (\x => x == '=') xs)- | [k, v] = Just (trim k, trim v)- | _ = Nothing--getContent : Int -> IO String-getContent x = getC (toNat x) "" where- getC : Nat -> String -> IO String- getC Z acc = return $ reverse acc- getC (S k) acc = do x <- getChar- getC k (strCons x acc)--getCgiEnv : String -> IO String-getCgiEnv key = do- val <- getEnv key- return $ maybe "" id val--abstract-runCGI : CGI a -> IO a-runCGI prog = do- clen_in <- getCgiEnv "CONTENT_LENGTH"- let clen = prim__fromStrInt clen_in- content <- getContent clen- query <- getCgiEnv "QUERY_STRING"- cookie <- getCgiEnv "HTTP_COOKIE"- agent <- getCgiEnv "HTTP_USER_AGENT"-- let get_vars = getVars ['&',';'] query- let post_vars = getVars ['&'] content- let cookies = getVars [';'] cookie-- (v, st) <- getAction prog (CGISt get_vars post_vars cookies agent- "Content-type: text/html\n"- "")- putStrLn (Headers st)- putStr (Output st)- return v--
− libs/base/Network/Socket.idr
@@ -1,363 +0,0 @@--- Time to do this properly.--- Low-Level C Sockets bindings for Idris. Used by higher-level, cleverer things.--- (C) SimonJF, MIT Licensed, 2014-module IdrisNet.Socket--%include C "idris_net.h"-%include C "sys/types.h"-%include C "sys/socket.h"-%include C "netdb.h"--%access public--ByteLength : Type-ByteLength = Int--class ToCode a where- toCode : a -> Int--||| Socket Families-|||-||| The ones that people might actually use. We're not going to need US-||| Government proprietary ones.-data SocketFamily =- ||| Unspecified- AF_UNSPEC |- ||| IP / UDP etc. IPv4- AF_INET |- ||| IP / UDP etc. IPv6- AF_INET6--instance Show SocketFamily where- show AF_UNSPEC = "AF_UNSPEC"- show AF_INET = "AF_INET"- show AF_INET6 = "AF_INET4"--instance ToCode SocketFamily where- toCode AF_UNSPEC = 0- toCode AF_INET = 2- toCode AF_INET6 = 10--getSocketFamily : Int -> Maybe SocketFamily-getSocketFamily i = Prelude.List.lookup i [(0, AF_UNSPEC), (2, AF_INET), (10, AF_INET6)]--||| Socket Types.-data SocketType =- ||| Not a socket, used in certain operations- NotASocket |- ||| TCP- Stream |- ||| UDP- Datagram |- ||| Raw sockets- RawSocket--instance Show SocketType where- show NotASocket = "Not a socket"- show Stream = "Stream"- show Datagram = "Datagram"- show RawSocket = "Raw"--instance ToCode SocketType where- toCode NotASocket = 0- toCode Stream = 1- toCode Datagram = 2- toCode RawSocket = 3---data RecvStructPtr = RSPtr Ptr-data RecvfromStructPtr = RFPtr Ptr-data BufPtr = BPtr Ptr-data SockaddrPtr = SAPtr Ptr--||| Protocol Number.-|||-||| Generally good enough to just set it to 0.-ProtocolNumber : Type-ProtocolNumber = Int--||| SocketError: Error thrown by a socket operation-SocketError : Type-SocketError = Int--||| SocketDescriptor: Native C Socket Descriptor-SocketDescriptor : Type-SocketDescriptor = Int--data SocketAddress = IPv4Addr Int Int Int Int- | IPv6Addr -- Not implemented (yet)- | Hostname String- | InvalidAddress -- Used when there's a parse error--instance Show SocketAddress where- show (IPv4Addr i1 i2 i3 i4) = concat $ Prelude.List.intersperse "." (map show [i1, i2, i3, i4])- show IPv6Addr = "NOT IMPLEMENTED YET"- show (Hostname host) = host- show InvalidAddress = "Invalid"--Port : Type-Port = Int--||| Backlog used within listen() call -- number of incoming calls-BACKLOG : Int-BACKLOG = 20---- FIXME: This *must* be pulled in from C-EAGAIN : Int -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 UDPAddrInfo : Type where- MkUDPAddrInfo : - (remote_addr : SocketAddress) ->- (remote_port : Port) ->- UDPAddrInfo--||| Frees a given pointer-public-sock_free : BufPtr -> IO ()-sock_free (BPtr ptr) = mkForeign (FFun "idrnet_free" [FPtr] FUnit) ptr--public-sockaddr_free : SockaddrPtr -> IO ()-sockaddr_free (SAPtr ptr) = mkForeign (FFun "idrnet_free" [FPtr] FUnit) ptr--||| Allocates an amount of memory given by the ByteLength parameter.-|||-||| Used to allocate a mutable pointer to be given to the Recv functions.-public-sock_alloc : ByteLength -> IO BufPtr-sock_alloc bl = map BPtr $ mkForeign (FFun "idrnet_malloc" [FInt] FPtr) bl--||| The metadata about a socket-record Socket : Type where- MkSocket : (descriptor : SocketDescriptor) ->- (family : SocketFamily) ->- (socketType : SocketType) ->- (protocolNumber : ProtocolNumber) ->- Socket--||| Get the C error number-getErrno : IO Int-getErrno = mkForeign (FFun "idrnet_errno" [] FInt)--||| Creates a UNIX socket with the given family, socket type and protocol-||| number. Returns either a socket or an error.-socket : SocketFamily -> SocketType -> ProtocolNumber -> IO (Either SocketError Socket)-socket sf st pn = do- socket_res <- mkForeign (FFun "socket" [FInt, FInt, FInt] FInt) (toCode sf) (toCode st) pn- if socket_res == -1 then -- error- map Left getErrno- else- return $ Right (MkSocket socket_res sf st pn)--||| Close a socket-close : Socket -> IO ()-close sock = mkForeign (FFun "close" [FInt] FUnit) (descriptor sock)--private-saString : (Maybe SocketAddress) -> String-saString (Just sa) = show sa-saString Nothing = ""--||| Binds a socket to the given socket address and port.-||| Returns 0 on success, an error code otherwise.-bind : Socket -> (Maybe SocketAddress) -> Port -> IO Int-bind sock addr port = do- bind_res <- (mkForeign (FFun "idrnet_bind" [FInt, FInt, FInt, FString, FInt] FInt)- (descriptor sock) (toCode $ family sock) (toCode $ socketType sock) (saString addr) port)- if bind_res == (-1) then -- error- getErrno- else return 0 -- Success--||| Connects to a given address and port.-||| Returns 0 on success, and an error number on error.-connect : Socket -> SocketAddress -> Port -> IO Int-connect sock addr port = do- conn_res <- (mkForeign (FFun "idrnet_connect" [FInt, FInt, FInt, FString, FInt] FInt)- (descriptor sock) (toCode $ family sock) (toCode $ socketType sock) (show addr) port)- if conn_res == (-1) then- getErrno- else return 0--||| Listens on a bound socket.-listen : Socket -> IO Int-listen sock = do- listen_res <- mkForeign (FFun "listen" [FInt, FInt] FInt) (descriptor sock) BACKLOG- if listen_res == (-1) then- getErrno- else return 0--||| Parses a textual representation of an IPv4 address into a SocketAddress-parseIPv4 : String -> SocketAddress-parseIPv4 str = case splitted of- (i1 :: i2 :: i3 :: i4 :: _) => IPv4Addr i1 i2 i3 i4- _ => InvalidAddress- where toInt' : String -> Integer- toInt' = cast- toInt : String -> Int- toInt s = fromInteger $ toInt' s- splitted : List Int- splitted = map toInt (Prelude.Strings.split (\c => c == '.') str)---||| Retrieves a socket address from a sockaddr pointer-getSockAddr : SockaddrPtr -> IO SocketAddress-getSockAddr (SAPtr ptr) = do- addr_family_int <- mkForeign (FFun "idrnet_sockaddr_family" [FPtr] FInt) ptr- -- putStrLn $ "Addr family int: " ++ (show addr_family_int)- -- ASSUMPTION: Foreign call returns a valid int- assert_total (case getSocketFamily addr_family_int of- Just AF_INET => do- ipv4_addr <- mkForeign (FFun "idrnet_sockaddr_ipv4" [FPtr] FString) ptr- return $ parseIPv4 ipv4_addr- Just AF_INET6 => return IPv6Addr- Just AF_UNSPEC => return InvalidAddress)--accept : Socket -> IO (Either SocketError (Socket, SocketAddress))-accept sock = do- -- We need a pointer to a sockaddr structure. This is then passed into- -- idrnet_accept and populated. We can then query it for the SocketAddr and free it.- sockaddr_ptr <- mkForeign (FFun "idrnet_create_sockaddr" [] FPtr)- accept_res <- mkForeign (FFun "idrnet_accept" [FInt, FPtr] FInt) (descriptor sock) sockaddr_ptr- if accept_res == (-1) then- map Left getErrno- else do- let (MkSocket _ fam ty p_num) = sock- sockaddr <- getSockAddr (SAPtr sockaddr_ptr)- sockaddr_free (SAPtr sockaddr_ptr)- return $ Right ((MkSocket accept_res fam ty p_num), sockaddr)--send : Socket -> String -> IO (Either SocketError ByteLength)-send sock dat = do- send_res <- mkForeign (FFun "idrnet_send" [FInt, FString] FInt) (descriptor sock) dat- if send_res == (-1) then- map Left getErrno- else- return $ Right send_res---freeRecvStruct : RecvStructPtr -> IO ()-freeRecvStruct (RSPtr p) = mkForeign (FFun "idrnet_free_recv_struct" [FPtr] FUnit) p--freeRecvfromStruct : RecvfromStructPtr -> IO ()-freeRecvfromStruct (RFPtr p) = mkForeign (FFun "idrnet_free_recvfrom_struct" [FPtr] FUnit) p--recv : Socket -> Int -> IO (Either SocketError (String, ByteLength))-recv sock len = do- -- Firstly make the request, get some kind of recv structure which- -- contains the result of the recv and possibly the retrieved payload- recv_struct_ptr <- mkForeign (FFun "idrnet_recv" [FInt, FInt] FPtr) (descriptor sock) len- recv_res <- mkForeign (FFun "idrnet_get_recv_res" [FPtr] FInt) recv_struct_ptr- if recv_res == (-1) then do- errno <- getErrno- freeRecvStruct (RSPtr recv_struct_ptr)- return $ Left errno- else - if recv_res == 0 then do- freeRecvStruct (RSPtr recv_struct_ptr)- return $ Left 0- else do- payload <- mkForeign (FFun "idrnet_get_recv_payload" [FPtr] FString) recv_struct_ptr- freeRecvStruct (RSPtr recv_struct_ptr)- return $ Right (payload, recv_res)---||| Sends the data in a given memory location-sendBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)-sendBuf sock (BPtr ptr) len = do- send_res <- mkForeign (FFun "idrnet_send_buf" [FInt, FPtr, FInt] FInt) (descriptor sock) ptr len- if send_res == (-1) then- map Left getErrno- else- return $ Right send_res--recvBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)-recvBuf sock (BPtr ptr) len = do- recv_res <- mkForeign (FFun "idrnet_recv_buf" [FInt, FPtr, FInt] FInt) (descriptor sock) ptr len- if (recv_res == (-1)) then- map Left getErrno- else- return $ Right recv_res--sendTo : Socket -> SocketAddress -> Port -> String -> IO (Either SocketError ByteLength)-sendTo sock addr p dat = do- sendto_res <- mkForeign (FFun "idrnet_sendto" [FInt, FString, FString, FInt, FInt] FInt)- (descriptor sock) dat (show addr) p (toCode $ family sock)- if sendto_res == (-1) then- map Left getErrno- else- return $ Right sendto_res---sendToBuf : Socket -> SocketAddress -> Port -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)-sendToBuf sock addr p (BPtr dat) len = do- sendto_res <- mkForeign (FFun "idrnet_sendto_buf" [FInt, FPtr, FInt, FString, FInt, FInt] FInt)- (descriptor sock) dat len (show addr) p (toCode $ family sock)- if sendto_res == (-1) then- map Left getErrno- else- return $ Right sendto_res---foreignGetRecvfromPayload : RecvfromStructPtr -> IO String-foreignGetRecvfromPayload (RFPtr p) = mkForeign (FFun "idrnet_get_recvfrom_payload" [FPtr] FString) p--foreignGetRecvfromAddr : RecvfromStructPtr -> IO SocketAddress-foreignGetRecvfromAddr (RFPtr p) = do- sockaddr_ptr <- map SAPtr $ mkForeign (FFun "idrnet_get_recvfrom_sockaddr" [FPtr] FPtr) p- getSockAddr sockaddr_ptr---foreignGetRecvfromPort : RecvfromStructPtr -> IO Port-foreignGetRecvfromPort (RFPtr p) = do- sockaddr_ptr <- mkForeign (FFun "idrnet_get_recvfrom_sockaddr" [FPtr] FPtr) p- port <- mkForeign (FFun "idrnet_sockaddr_ipv4_port" [FPtr] FInt) sockaddr_ptr- return port--recvFrom : Socket -> ByteLength -> IO (Either SocketError (UDPAddrInfo, String, ByteLength))-recvFrom sock bl = do- recv_ptr <- mkForeign (FFun "idrnet_recvfrom" [FInt, FInt] FPtr) - (descriptor sock) bl- let recv_ptr' = RFPtr recv_ptr- if !(nullPtr recv_ptr) then- map Left getErrno- else do- result <- mkForeign (FFun "idrnet_get_recvfrom_res" [FPtr] FInt) recv_ptr- if result == -1 then do- freeRecvfromStruct recv_ptr'- map Left getErrno- else do- payload <- foreignGetRecvfromPayload recv_ptr'- port <- foreignGetRecvfromPort recv_ptr'- addr <- foreignGetRecvfromAddr recv_ptr'- freeRecvfromStruct recv_ptr'- return $ Right (MkUDPAddrInfo addr port, payload, result)---recvFromBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError (UDPAddrInfo, ByteLength))-recvFromBuf sock (BPtr ptr) bl = do- recv_ptr <- mkForeign (FFun "idrnet_recvfrom_buf" [FInt, FPtr, FInt] FPtr) (descriptor sock) ptr bl- let recv_ptr' = RFPtr recv_ptr- if !(nullPtr recv_ptr) then- map Left getErrno- else do- result <- mkForeign (FFun "idrnet_get_recvfrom_res" [FPtr] FInt) recv_ptr- if result == -1 then do- freeRecvfromStruct recv_ptr'- map Left getErrno- else do- port <- foreignGetRecvfromPort recv_ptr'- addr <- foreignGetRecvfromAddr recv_ptr'- freeRecvfromStruct recv_ptr'- return $ Right (MkUDPAddrInfo addr port, result + 1)--
− libs/base/Providers.idr
@@ -1,27 +0,0 @@-module Providers--||| Type providers must build one of these in an IO computation.-public-data Provider : (a : Type) -> Type where- ||| Return a term to be spliced in- ||| @ x the term to be spliced (i.e. the proof)- Provide : (x : a) -> Provider a-- ||| Report an error to the user and stop compilation- ||| @ msg the error message- Error : (msg : String) -> Provider a---- instances-instance Functor Provider where- map f (Provide a) = Provide (f a)- map f (Error err) = Error err--instance Applicative Provider where- (Provide f) <$> (Provide x) = Provide (f x)- (Provide f) <$> (Error err) = Error err- (Error err) <$> _ = Error err- pure = Provide--instance Monad Provider where- (Provide x) >>= f = f x- (Error err) >>= _ = Error err
libs/base/System.idr view
@@ -10,10 +10,10 @@ ga' [] 0 n where numArgs : IO Int- numArgs = mkForeign (FFun "idris_numArgs" [] FInt)+ numArgs = foreign FFI_C "idris_numArgs" (IO Int) getArg : Int -> IO String- getArg x = mkForeign (FFun "idris_getArg" [FInt] FString) x+ getArg x = foreign FFI_C "idris_getArg" (Int -> IO String) x ga' : List String -> Int -> Int -> IO (List String) ga' acc i n = if (i == n) then (return $ reverse acc) else@@ -31,27 +31,27 @@ else pure (Just str_ptr) where getEnv' : IO String- getEnv' = mkForeign (FFun "getenv" [FString] FString) key+ getEnv' = foreign FFI_C "getenv" (String -> IO String) key ||| Sets an environment variable with a given value. ||| Returns true if the operation was successful. setEnv : String -> String -> IO Bool setEnv key value = do- ok <- mkForeign (FFun "setenv" [FString, FString, FInt] FInt) key value 1+ ok <- foreign FFI_C "setenv" (String -> String -> Int -> IO Int) key value 1 return (ok == 0) ||| Unsets an environment variable. ||| Returns true if the variable was able to be unset. unsetEnv : String -> IO Bool unsetEnv key = do- ok <- mkForeign (FFun "unsetenv" [FString] FInt) key+ ok <- foreign FFI_C "unsetenv" (String -> IO Int) key return (ok == 0) getEnvironment : IO (List (String, String)) getEnvironment = getAllPairs 0 [] where getEnvPair : Int -> IO String- getEnvPair i = mkForeign (FFun "getEnvPair" [FInt] FString) i+ getEnvPair i = foreign FFI_C "getEnvPair" (Int -> IO String) i splitEq : String -> (String, String) splitEq str =@@ -70,15 +70,15 @@ ||| Quit with a particular exit code exit : Int -> IO ()-exit code = mkForeign (FFun "exit" [FInt] FUnit) code+exit code = foreign FFI_C "exit" (Int -> IO ()) code ||| Get the Unix time time : IO Int-time = mkForeign (FFun "idris_time" [] FInt)+time = foreign FFI_C "idris_time" (IO Int) usleep : Int -> IO ()-usleep i = mkForeign (FFun "usleep" [FInt] FUnit) i+usleep i = foreign FFI_C "usleep" (Int -> IO ()) i system : String -> IO Int-system cmd = mkForeign (FFun "system" [FString] FInt) cmd+system cmd = foreign FFI_C "system" (String -> IO Int) cmd
− libs/base/System/Concurrency/Process.idr
@@ -1,61 +0,0 @@--- WARNING: No guarantees that this works properly yet!--module System.Concurrency.Process--import System.Concurrency.Raw--%access public--abstract-data ProcID msg = MkPID Ptr--||| Type safe message passing programs. Parameterised over the type of-||| message which can be send, and the return type.-data Process : (msgType : Type) -> Type -> Type where- Lift : IO a -> Process msg a--instance Functor (Process msg) where- map f (Lift a) = Lift (map f a)--instance Applicative (Process msg) where- pure = Lift . return- (Lift f) <$> (Lift a) = Lift (f <$> a)--instance Monad (Process msg) where- (Lift io) >>= k = Lift (do x <- io- case k x of- Lift v => v)--run : Process msg x -> IO x-run (Lift prog) = prog--||| Get current process ID-myID : Process msg (ProcID msg)-myID = Lift (return (MkPID prim__vm))--||| Send a message to another process-send : ProcID msg -> msg -> Process msg ()-send (MkPID p) m = Lift (sendToThread p (prim__vm, m))--||| Return whether a message is waiting in the queue-msgWaiting : Process msg Bool-msgWaiting = Lift checkMsgs--||| Receive a message - blocks if there is no message waiting-recv : Process msg msg-recv {msg} = do (senderid, m) <- Lift get- return m- where get : IO (Ptr, msg)- get = getMsg--||| receive a message, and return with the sender's process ID.-recvWithSender : Process msg (ProcID msg, msg)-recvWithSender {msg}- = do (senderid, m) <- Lift get- return (MkPID senderid, m)- where get : IO (Ptr, msg)- get = getMsg--create : Process msg () -> Process msg (ProcID msg)-create (Lift p) = do ptr <- Lift (fork p)- return (MkPID ptr)
libs/base/System/Concurrency/Raw.idr view
@@ -9,16 +9,62 @@ ||| Send a message of any type to the thread with the given thread id sendToThread : (thread_id : Ptr) -> a -> IO () sendToThread {a} dest val- = mkForeign (FFun "idris_sendMessage"- [FPtr, FPtr, FAny a] FUnit) prim__vm dest val+ = foreign FFI_C "idris_sendMessage" (Ptr -> Ptr -> Raw a -> IO ())+ prim__vm dest (MkRaw val) +||| Check for messages in the process inbox checkMsgs : IO Bool-checkMsgs = do msgs <- mkForeign (FFun "idris_checkMessages"- [FPtr] FInt) prim__vm- return (intToBool msgs)+checkMsgs = do msgs <- foreign FFI_C "idris_checkMessages" (Ptr -> IO Ptr)+ prim__vm+ null <- nullPtr msgs+ return (not null) +||| Check for messages in the process inbox.+||| Returns either 'Nothing', if none, or 'Just pid' as pid of sender.+listenMsgs : IO (Maybe Ptr)+listenMsgs = do sender <- foreign FFI_C "idris_checkMessages" (Ptr -> IO Ptr)+ prim__vm+ null <- nullPtr sender+ return (if null+ then Nothing+ else Just sender)++||| Check for messages from a specific sender in the process inbox+checkMsgsFrom : Ptr -> IO Bool+checkMsgsFrom sender+ = do msgs <- foreign FFI_C "idris_checkMessagesFrom" (Ptr -> Ptr -> IO Ptr)+ prim__vm sender+ null <- nullPtr msgs+ return (not null)+ ||| Check inbox for messages. If there are none, blocks until a message ||| arrives.+||| Note that this is not at all type safe! It is intended to be used in+||| a type safe wrapper. getMsg : IO a-getMsg {a} = mkForeign (FFun "idris_recvMessage"- [FPtr] (FAny a)) prim__vm+getMsg {a} = do m <- foreign FFI_C "idris_recvMessage" + (Ptr -> IO Ptr) prim__vm+ MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m+ return x++||| Check inbox for messages. If there are none, blocks until a message+||| arrives. Return pair of sender's ID and the message.+||| Note that this is not at all type safe! It is intended to be used in+||| a type safe wrapper.+getMsgWithSender : IO (Ptr, a)+getMsgWithSender {a} + = do m <- foreign FFI_C "idris_recvMessage" + (Ptr -> IO Ptr) prim__vm+ MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m+ vm <- foreign FFI_C "idris_getSender" (Ptr -> IO Ptr) m+ foreign FFI_C "idris_freeMsg" (Ptr -> IO ()) m+ return (vm, x)++getMsgFrom : Ptr -> IO a+getMsgFrom {a} sender + = do m <- foreign FFI_C "idris_recvMessageFrom"+ (Ptr -> Ptr -> IO Ptr) prim__vm sender+ MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m+ foreign FFI_C "idris_freeMsg" (Ptr -> IO ()) m+ return x+
libs/base/base.ipkg view
@@ -3,36 +3,29 @@ opts = "--nobasepkgs --total -i ../prelude" modules = System, - Network.Cgi, Network.Socket, Debug.Error, Debug.Trace, System.Info,- System.Concurrency.Raw, System.Concurrency.Process, - Decidable.Decidable, Decidable.Order,-- Providers,- Language.Reflection.Utils, Syntax.PreorderReasoning, Data.Morphisms, Data.Bits, Data.Mod2,- Data.ZZ, Data.Sign,- Data.SortedMap, Data.SortedSet, Data.BoundedList,- Data.Fin, Data.Vect, Data.VectType, + Data.Fin, Data.Vect, Data.VectType, Data.HVect, Data.Vect.Quantifiers,- Data.Floats, Data.Complex, Data.Heap, Data.Fun,- Data.Rel, Data.Buffer, Data.Erased,- Data.List, Data.Hash, Data.Matrix,+ Data.Floats, Data.Complex,+ Data.Erased, Data.List, Data.So, - Control.Isomorphism, Control.Isomorphism.Primitives,+ Control.Isomorphism, Control.Monad.Identity, Control.Monad.RWS, Control.Monad.Trans, Control.Monad.State, Control.Monad.Writer, Control.Monad.Reader, Control.Category, Control.Arrow,- Control.Catchable, Control.IOExcept+ Control.Catchable, Control.IOExcept,++ System.Concurrency.Raw
+ libs/contrib/Classes/Verified.idr view
@@ -0,0 +1,114 @@+module Classes.Verified++import Control.Algebra++-- 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+-- be implemented for a number of instances, and we get those+-- implementations, then some of them can move back to base (or even+-- prelude, in the cases of Functor, Applicative, Monad, Semigroup,+-- and Monoid).++class Functor f => VerifiedFunctor (f : Type -> Type) where+ functorIdentity : {a : Type} -> (x : f a) -> map id x = id x+ functorComposition : {a : Type} -> {b : Type} -> (x : f a) ->+ (g1 : a -> b) -> (g2 : b -> c) ->+ map (g2 . g1) x = (map g2 . map g1) x++++class (Applicative f, VerifiedFunctor f) => VerifiedApplicative (f : Type -> Type) where+ applicativeMap : (x : f a) -> (g : a -> b) ->+ map g x = pure g <*> x+ applicativeIdentity : (x : f a) -> pure id <*> x = x+ applicativeComposition : (x : f a) -> (g1 : f (a -> b)) -> (g2 : f (b -> c)) ->+ ((pure (.) <*> g2) <*> g1) <*> x = g2 <*> (g1 <*> x)+ applicativeHomomorphism : (x : a) -> (g : a -> b) ->+ (<*>) {f} (pure g) (pure x) = pure {f} (g x)+ applicativeInterchange : (x : a) -> (g : f (a -> b)) ->+ g <*> pure x = pure (\g' : a -> b => g' x) <*> g+++class (Monad m, VerifiedApplicative m) => VerifiedMonad (m : Type -> Type) where+ monadApplicative : (mf : m (a -> b)) -> (mx : m a) ->+ mf <*> mx = mf >>= \f =>+ mx >>= \x =>+ pure (f x)+ monadLeftIdentity : (x : a) -> (f : a -> m b) -> return x >>= f = f x+ monadRightIdentity : (mx : m a) -> mx >>= return = mx+ monadAssociativity : (mx : m a) -> (f : a -> m b) -> (g : b -> m c) ->+ (mx >>= f) >>= g = mx >>= (\x => f x >>= g)+++class Semigroup a => VerifiedSemigroup a where+ total semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r++instance VerifiedSemigroup (List a) where+ semigroupOpIsAssociative = appendAssociative++--instance VerifiedSemigroup Nat where+-- semigroupOpIsAssociative = plusAssociative+++class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where+ total monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l+ total monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r++-- instance VerifiedMonoid Nat where+-- monoidNeutralIsNeutralL = plusZeroRightNeutral+-- monoidNeutralIsNeutralR = plusZeroLeftNeutral++instance VerifiedMonoid (List a) where+ monoidNeutralIsNeutralL = appendNilRightNeutral+ monoidNeutralIsNeutralR xs = Refl++class (VerifiedMonoid a, Group a) => VerifiedGroup a where+ total groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral+ total groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral++class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where+ total abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l++class (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where+ total ringOpIsAssociative : (l, c, r : a) -> l <.> (c <.> r) = (l <.> c) <.> r+ total ringOpIsDistributiveL : (l, c, r : a) -> l <.> (c <+> r) = (l <.> c) <+> (l <.> r)+ total ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <.> r = (l <.> r) <+> (c <.> r)++class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where+ total ringWithUnityIsUnityL : (l : a) -> l <.> unity = l+ total ringWithUnityIsUnityR : (r : a) -> unity <.> r = r++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+ total joinSemilatticeJoinIsIdempotent : (e : a) -> join e e = e++class MeetSemilattice a => VerifiedMeetSemilattice a where+ total meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r+ total meetSemilatticeMeetIsCommutative : (l, r : a) -> meet l r = meet r l+ total meetSemilatticeMeetIsIdempotent : (e : a) -> meet e e = e++class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where+ total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = e++class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where+ total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = e++class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where+ total latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l+ total latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l++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 {}+
+ libs/contrib/Control/Algebra.idr view
@@ -0,0 +1,274 @@+module Control.Algebra++import Data.Heap++-- XXX: change?+infixl 6 <->+infixl 6 <.>+infixl 5 <#>++||| 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:+||| + Associativity of `<+>`:+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+||| + Neutral for `<+>`:+||| forall a, a <+> neutral == a+||| forall a, neutral <+> a == a+||| + Inverse for `<+>`:+||| forall a, a <+> inverse a == neutral+||| forall a, inverse a <+> a == neutral+class Monoid a => Group a where+ inverse : a -> a++(<->) : Group a => a -> a -> a+(<->) left right = left <+> (inverse right)++||| Sets equipped with a single binary operation that is associative and+||| commutative, along with a neutral element for that binary operation and+||| inverses for all elements. Must satisfy the following laws:+|||+||| + Associativity of `<+>`:+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+||| + Commutativity of `<+>`:+||| forall a b, a <+> b == b <+> a+||| + Neutral for `<+>`:+||| forall a, a <+> neutral == a+||| forall a, neutral <+> a == a+||| + Inverse for `<+>`:+||| forall a, a <+> inverse a == neutral+||| forall a, inverse a <+> a == neutral+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+||| laws:+|||+||| + Associativity of `<+>`:+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+||| + Commutativity of `<+>`:+||| forall a b, a <+> b == b <+> a+||| + Neutral for `<+>`:+||| forall a, a <+> neutral == a+||| forall a, neutral <+> a == a+||| + Inverse for `<+>`:+||| forall a, a <+> inverse a == neutral+||| forall a, inverse a <+> a == neutral+||| + Associativity of `<.>`:+||| forall a b c, a <.> (b <.> c) == (a <.> b) <.> c+||| + 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 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+||| satisfy the following laws:+|||+||| + Associativity of `<+>`:+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+||| + Commutativity of `<+>`:+||| forall a b, a <+> b == b <+> a+||| + Neutral for `<+>`:+||| forall a, a <+> neutral == a+||| forall a, neutral <+> a == a+||| + Inverse for `<+>`:+||| forall a, a <+> inverse a == neutral+||| forall a, inverse a <+> a == neutral+||| + Associativity of `<.>`:+||| forall a b c, a <.> (b <.> c) == (a <.> b) <.> c+||| + Neutral for `<.>`:+||| forall a, a <.> unity == a+||| forall a, unity <.> a == a+||| + 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 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:+|||+||| + Associativity of `<+>`:+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+||| + Commutativity of `<+>`:+||| forall a b, a <+> b == b <+> a+||| + Neutral for `<+>`:+||| forall a, a <+> neutral == a+||| forall a, neutral <+> a == a+||| + Inverse for `<+>`:+||| forall a, a <+> inverse a == neutral+||| forall a, inverse a <+> a == neutral+||| + Associativity of `<.>`:+||| forall a b c, a <.> (b <.> c) == (a <.> b) <.> c+||| + Unity for `<.>`:+||| forall a, a <.> unity == a+||| forall a, unity <.> a == a+||| + InverseM of `<.>`:+||| forall a, a <.> inverseM a == unity+||| forall a, inverseM a <.> a == unity+||| + Distributivity of `<.>` and `<->`:+||| forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c)+||| forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)+class RingWithUnity a => Field a where+ inverseM : a -> a+++||| 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 {}+++-- XXX todo:+-- Structures where "abs" make sense.+-- Euclidean domains, etc.+-- Where to put fromInteger and fromRational?
+ libs/contrib/Control/Isomorphism/Primitives.idr view
@@ -0,0 +1,35 @@+module Control.Isomorphism.Primitives++import Control.Isomorphism+import Data.ZZ++%default total+%access public++-- This module contains isomorphisms between convenient inductive types and+-- Idris primitives. Because primitives lack a convenient structure, these+-- arguments typically end with "really_believe_me". This is why they are in a+-- separate module.++integerIsoZZ : Iso Integer ZZ+integerIsoZZ = MkIso toZZ fromZZ fromToZZ toFromZZ+ where toZZ : Integer -> ZZ+ toZZ n = cast n++ fromZZ : ZZ -> Integer+ fromZZ n = cast n++ toFromZZ : (n : Integer) -> fromZZ (toZZ n) = n+ toFromZZ n = really_believe_me {a = n=n} {b = fromZZ (toZZ n) = n} Refl++ fromToZZ : (n : ZZ) -> toZZ (fromZZ n) = n+ fromToZZ n = really_believe_me {a = n=n} {b = toZZ (fromZZ n) = n} Refl+++packUnpackIso : Iso (List Char) String+packUnpackIso = MkIso pack+ unpack+ (\str => really_believe_me {a = str=str} {b = pack (unpack str) = str} Refl)+ (\cs => really_believe_me {a = cs=cs} {b = unpack (pack cs) = cs} Refl)++
+ libs/contrib/Data/BoundedList.idr view
@@ -0,0 +1,96 @@+module Data.BoundedList++import Data.Fin++%access public+%default total++||| A list with an upper bound on its length.+data BoundedList : Nat -> Type -> Type where+ Nil : BoundedList n a+ (::) : a -> BoundedList n a -> BoundedList (S n) a++||| Compute the length of a list.+length : BoundedList n a -> Fin (S n)+length [] = FZ+length (x :: xs) = FS (length xs)++--------------------------------------------------------------------------------+-- Indexing into bounded lists+--------------------------------------------------------------------------------++index : Fin (S n) -> BoundedList n a -> Maybe a+index _ [] = Nothing+index FZ (x :: _) = Just x+index (FS f) (_ :: xs) = index f xs++--------------------------------------------------------------------------------+-- Adjusting bounds+--------------------------------------------------------------------------------++||| Loosen the bounds on a list's length.+weaken : BoundedList n a -> BoundedList (n + m) a+weaken [] = []+weaken (x :: xs) = x :: weaken xs++--------------------------------------------------------------------------------+-- Conversions to and from list+--------------------------------------------------------------------------------++take : (n : Nat) -> List a -> BoundedList n a+take _ [] = []+take Z _ = []+take (S n') (x :: xs) = x :: take n' xs++toList : BoundedList n a -> List a+toList [] = []+toList (x :: xs) = x :: Data.BoundedList.toList xs++fromList : (xs : List a) -> BoundedList (length xs) a+fromList [] = []+fromList (x :: xs) = x :: fromList xs++--------------------------------------------------------------------------------+-- Building (bigger) bounded lists+--------------------------------------------------------------------------------++replicate : (n : Nat) -> a -> BoundedList n a+replicate Z _ = []+replicate (S n) x = x :: replicate n x++--------------------------------------------------------------------------------+-- Folds+--------------------------------------------------------------------------------++instance Foldable (BoundedList n) where+ foldr f e [] = e+ foldr f e (x::xs) = f x (foldr f e xs)+ foldl f e [] = e+ foldl f e (x::xs) = foldl f (f e x) xs++--------------------------------------------------------------------------------+-- Maps+--------------------------------------------------------------------------------++instance Functor (BoundedList n) where+ map f [] = []+ map f (x :: xs) = f x :: map f xs++--------------------------------------------------------------------------------+-- Misc+--------------------------------------------------------------------------------++||| Extend a bounded list to the maximum size by padding on the left.+pad : BoundedList n a -> a -> BoundedList n a+pad {n=Z} [] _ = []+pad {n=S n'} [] padding = padding :: (pad {n=n'} [] padding)+pad {n=S n'} (x :: xs) padding = x :: pad {n=n'} xs padding+++--------------------------------------------------------------------------------+-- Simple properties+--------------------------------------------------------------------------------++zeroBoundIsEmpty : (xs : BoundedList 0 a) -> xs = the (BoundedList 0 a) []+zeroBoundIsEmpty [] = Refl+zeroBoundIsEmpty (_ :: _) impossible
+ libs/contrib/Data/Buffer.idr view
@@ -0,0 +1,254 @@+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/Fun.idr view
@@ -0,0 +1,17 @@+module Data.Fun++import Data.Vect++%default total++||| Build an n-ary function type from a Vect of Types and a result type+Fun : Vect n Type -> Type -> Type+Fun [] r = r+Fun (t::ts) r = t -> Fun ts r++chain : {ts : Vect n Type} -> Fun [r] r' -> Fun ts r -> Fun ts r'+chain {ts = []} g r = g r+chain {ts = (_::_)} g f = \ x => chain g (f x)++target : {ts : Vect n Type} -> Fun ts r -> Type+target {r} _ = r
+ libs/contrib/Data/Hash.idr view
@@ -0,0 +1,87 @@+module Data.Hash++import Data.Vect++%access public+%default total++{- A general purpose Hashing library (not cryptographic)++ The core hash is djb2, which is very fast but does not have the best distribution+ Source: http://www.cse.yorku.ca/~oz/hash.html++ The salted version and the magic salt are copied from Haskell's bloomfilter library+ Source: https://hackage.haskell.org/package/bloomfilter-2.0.0.0/docs/src/Data-BloomFilter-Hash.html#Hashable+-}++||| A type that can be hashed+class Hashable a where+ saltedHash64 : a -> Bits64 -> Bits64 -- value to hash, salt, hash++||| Computes a non cryptographic hash+hash : Hashable a => a -> Bits64+hash x = saltedHash64 x 0x16fc397cf62f64d3++||| Given a user provided salt, computes a non cryptographic hash.+||| This version is meant to mitigate hash-flooding DoS attacks.+saltedHash : Hashable a => Bits64 -> a -> Bits64+saltedHash salt x = saltedHash64 x salt+++||| Nth byte of a Bits64+private+byte : Bits64 -> Bits64 -> Bits64+byte n w = prim__lshrB64 (prim__andB64 mask w) offset+ where offset = 8*n+ mask = prim__shlB64 0xff (the Bits64 offset)++||| Modulo of an integer, downsized to a Bits64+private+mod64 : Integer -> Bits64+mod64 i = assert_total $ prim__truncBigInt_B64 (abs i `mod` 0xffffffffffffffff)++instance Hashable Bits64 where+ saltedHash64 w salt = foldr (\b,acc => (acc `prim__shlB64` 10) + acc + b)+ salt+ [byte (fromInteger n) w | n <- [7,6..0]] -- djb2 hash function. Not meant for crypto++instance Hashable Integer where+ saltedHash64 i = saltedHash64 (mod64 i)++instance Hashable () where+ saltedHash64 _ salt = salt++instance Hashable Bool where+ saltedHash64 True = saltedHash64 (the Bits64 1)+ saltedHash64 False = saltedHash64 (the Bits64 0)++instance Hashable Int where+ saltedHash64 w = saltedHash64 (prim__zextInt_B64 w)++instance Hashable Char where+ saltedHash64 w = saltedHash64 (the Int (cast w))++instance Hashable Bits8 where+ saltedHash64 w = saltedHash64 (prim__zextB8_B64 w)++instance Hashable Bits16 where+ saltedHash64 w = saltedHash64 (prim__zextB16_B64 w)++instance Hashable Bits32 where+ saltedHash64 w = saltedHash64 (prim__zextB32_B64 w)++instance Hashable a => Hashable (Maybe a) where+ saltedHash64 Nothing salt = salt+ saltedHash64 (Just k) salt = saltedHash64 k salt++instance (Hashable a, Hashable b) => Hashable (a, b) where+ saltedHash64 (a,b) salt = saltedHash64 b (saltedHash64 a salt)++instance Hashable a => Hashable (List a) where+ saltedHash64 l salt = foldr (\c,acc => saltedHash64 c acc) salt l++instance Hashable a => Hashable (Vect n a) where+ saltedHash64 l salt = foldr (\c,acc => saltedHash64 c acc) salt l++instance Hashable String where+ saltedHash64 s = saltedHash64 (unpack s)
+ libs/contrib/Data/Heap.idr view
@@ -0,0 +1,187 @@+--------------------------------------------------------------------------------+-- Okasaki-style maxiphobic heaps. See the paper:+-- ``Fun with binary heap trees'', Chris Okasaki, Fun of programming, 2003.+--------------------------------------------------------------------------------++module Data.Heap+++%default total+%access public++abstract data MaxiphobicHeap : Type -> Type where+ Empty : MaxiphobicHeap a+ Node : Nat -> MaxiphobicHeap a -> a -> MaxiphobicHeap a -> MaxiphobicHeap a++----------------------------------------- ---------------------------------------+-- Syntactic tests+--------------------------------------------------------------------------------++total isEmpty : MaxiphobicHeap a -> Bool+isEmpty Empty = True+isEmpty _ = False++total size : MaxiphobicHeap a -> Nat+size Empty = Z+size (Node s l e r) = s++isValidHeap : Ord a => MaxiphobicHeap a -> Bool+isValidHeap Empty = True+isValidHeap (Node s l e r) =+ dominates e l && dominates e r && s == S (size l + size r)+ where+ dominates : Ord a => a -> MaxiphobicHeap a -> Bool+ dominates e Empty = True+ dominates e (Node s l e' r) = e' <= e++--------------------------------------------------------------------------------+-- Basic heaps+--------------------------------------------------------------------------------++total empty : MaxiphobicHeap a+empty = Empty++total singleton : a -> MaxiphobicHeap a+singleton e = Node 1 Empty e Empty++--------------------------------------------------------------------------------+-- Inserting items and merging heaps+--------------------------------------------------------------------------------++private orderBySize : MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a ->+ (MaxiphobicHeap a, MaxiphobicHeap a, MaxiphobicHeap a)+orderBySize left centre right =+ if size left == largest then+ (left, centre, right)+ else if size centre == largest then+ (centre, left, right)+ else+ (right, left, centre)+ where+ largest : Nat+ largest = maximum (size left) $ maximum (size centre) (size right)++%assert_total -- relies on orderBySize doing the right thing+merge : Ord a => MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a+merge Empty right = right+merge left Empty = left+merge (Node ls ll le lr) (Node rs rl re rr) =+ if le < re then+ let (largest, b, c) = orderBySize ll lr (Node rs rl re rr) in+ Node mergedSize largest le (merge b c)+ else+ let (largest, b, c) = orderBySize rl rr (Node ls ll le lr) in+ Node mergedSize largest re (merge b c)+ where+ mergedSize : Nat+ mergedSize = ls + rs++insert : Ord a => a -> MaxiphobicHeap a -> MaxiphobicHeap a+insert e = merge $ singleton e++--------------------------------------------------------------------------------+-- Heap operations+--------------------------------------------------------------------------------++findMinimum : (h : MaxiphobicHeap a) -> (isEmpty h = False) -> a+findMinimum Empty Refl impossible+findMinimum (Node s l e r) p = e++deleteMinimum : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> MaxiphobicHeap a+deleteMinimum Empty Refl impossible+deleteMinimum (Node s l e r) p = merge l r++--------------------------------------------------------------------------------+-- Conversions to and from lists (and a derived heap sorting algorithm)+--------------------------------------------------------------------------------++toList : Ord a => MaxiphobicHeap a -> List a+toList Empty = []+toList (Node s l e r) = toList' (Node s l e r) Refl+ where+ %assert_total -- relies on deleteMinimum making heap smaller+ toList' : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> List a+ toList' heap p = findMinimum heap p :: (Heap.toList (deleteMinimum heap p))++fromList : Ord a => List a -> MaxiphobicHeap a+fromList = foldr insert empty++sort : Ord a => List a -> List a+sort = Heap.toList . Heap.fromList++--------------------------------------------------------------------------------+-- Class instances+--------------------------------------------------------------------------------++instance Show a => Show (MaxiphobicHeap a) where+ show Empty = "Empty"+ show (Node s l e r) = "Node (" ++ show l ++ " " ++ show e ++ " " ++ show r ++ ")"++instance Eq a => Eq (MaxiphobicHeap a) where+ Empty == Empty = True+ (Node ls ll le lr) == (Node rs rl re rr) =+ ls == rs && ll == rl && le == re && lr == rr+ _ == _ = False++instance Ord a => Semigroup (MaxiphobicHeap a) where+ (<+>) = merge++instance Ord a => Monoid (MaxiphobicHeap a) where+ neutral = empty++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++total absurdBoolDischarge : False = True -> Void+absurdBoolDischarge p = replace {P = disjointTy} p ()+ where+ total disjointTy : Bool -> Type+ disjointTy False = ()+ disjointTy True = Void++total isEmptySizeZero : (h : MaxiphobicHeap a) -> (isEmpty h = True) -> size h = Z+isEmptySizeZero Empty p = Refl+isEmptySizeZero (Node s l e r) p = ?isEmptySizeZeroNodeAbsurd++total emptyHeapValid : Ord a => isValidHeap (empty {a}) = True+emptyHeapValid = Refl++total singletonHeapValid : Ord a => (e : a) -> isValidHeap $ singleton e = True+singletonHeapValid e = Refl++{-+total mergePreservesValidHeaps : Ord a => (left : MaxiphobicHeap a) ->+ (right : MaxiphobicHeap a) -> (leftValid : isValidHeap left = True) ->+ (rightValid : isValidHeap right = True) -> isValidHeap $ merge left right = True+mergePreservesValidHeaps Empty Empty lp rp = Refl+mergePreservesValidHeaps Empty (Node rs rl re rr) lp rp = rp+mergePreservesValidHeaps (Node ls ll le lr) Empty lp rp = lp+mergePreservesValidHeaps (Node ls ll le lr) (Node rs rl re rr) lp rp =+ ?mergePreservesValidHeapsBody+-}++--------------------------------------------------------------------------------+-- Proofs+--------------------------------------------------------------------------------++isEmptySizeZeroNodeAbsurd = proof {+ intros;+ refine void;+ refine absurdBoolDischarge;+ exact p;+}++--------------------------------------------------------------------------------+-- Debug+--------------------------------------------------------------------------------++{- XXX: poor performance when compiled, diverges when used in the REPL, but it+ does seem to work correctly!+main : IO ()+main = do+ _ <- printLn $ main.sort [10, 3, 7, 2, 9, 1, 8, 0, 6, 4, 5]+ _ <- printLn $ main.sort ["orange", "apple", "pear", "lime", "durian"]+ _ <- printLn $ main.sort [("jim", 19, "cs"), ("alice", 20, "english"), ("bob", 50, "engineering")]+ return ()+-}
+ libs/contrib/Data/Matrix.idr view
@@ -0,0 +1,250 @@+module Data.Matrix++import Control.Algebra++import Data.Complex+import Data.ZZ+import Data.Fin+import Data.Vect++%default total++infixr 2 <:> -- vector inner product+infixr 2 >< -- vector outer product+infixr 2 <<>> -- matrix commutator+infixr 2 >><< -- matrix anticommutator+infixl 3 <\> -- row times a matrix+infixr 4 </> -- matrix times a column+infixr 5 <> -- matrix multiplication+infixr 7 \&\ -- vector tensor product+infixr 7 <&> -- matrix tensor product++-----------------------------------------------------------------------+-- Vectors as members of algebraic classes+-----------------------------------------------------------------------++instance Semigroup a => Semigroup (Vect n a) where+ (<+>) v w = zipWith (<+>) v w++instance Monoid a => Monoid (Vect n a) where+ neutral {n} = replicate n neutral++instance Group a => Group (Vect n a) where+ inverse = map inverse++instance AbelianGroup a => AbelianGroup (Vect n a) where {}++instance Ring a => Ring (Vect n a) where+ (<.>) v w = zipWith (<.>) v w++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 RingWithUnity a => Module a (Vect n a) where+ (<#>) r v = map (r <.>) v++instance RingWithUnity a => Module a (Vect n (Vect l a)) where+ (<#>) r m = map (r <#>) m+-- should be Module a b => Module a (Vect n b), but results in 'overlapping instance'++-----------------------------------------------------------------------+-- (Ring) Vector functions+-----------------------------------------------------------------------++||| Inner product of ring vectors+(<:>) : Ring a => Vect n a -> Vect n a -> a+(<:>) w v = foldr (<+>) neutral (zipWith (<.>) w v)++||| Tensor multiply (⊗) ring vectors+(\&\) : Ring a => Vect n a -> Vect m a -> Vect (n * m) a+(\&\) {n} {m} v w = zipWith (<.>) (oextend m v) (orep n w) where+ orep : (n : Nat) -> Vect m a -> Vect (n * m) a+ orep n v = concat $ replicate n v+ oextend : (n : Nat) -> Vect k a -> Vect (k * n) a+ oextend n w = concat $ map (replicate n) w++||| Standard basis vector with one nonzero entry, ring data type and vector-length unfixed+basis : RingWithUnity a => {d : Nat} -> (Fin d) -> Vect d a+basis i = replaceAt i unity $ neutral++-----------------------------------------------------------------------+-- Matrix functions+-----------------------------------------------------------------------++||| Matrix with n rows and m columns+Matrix : Nat -> Nat -> Type -> Type+Matrix n m a = Vect n (Vect m a)++||| Gets the specified column of a matrix. For rows use the vector function 'index'+getCol : Fin m -> Matrix n m a -> Vect n a+getCol fm q = map (index fm) q++||| Deletes the specified column of a matrix. For rows use the vector function 'deleteAt'+deleteCol : Fin (S m) -> Matrix n (S m) a -> Matrix n m a+deleteCol f m = map (deleteAt f) m++||| Matrix element at specified row and column indices+indices : Fin n -> Fin m -> Matrix n m a -> a+indices f1 f2 m = index f2 (index f1 m)++||| Matrix times a column vector+(</>) : Ring a => Matrix n m a -> Vect m a -> Vect n a+(</>) m v = map (v <:>) m++||| Matrix times a row vector+(<\>) : Ring a => Vect n a -> Matrix n m a -> Vect m a+(<\>) r m = map (r <:>) $ transpose m++||| Matrix multiplication+(<>) : Ring a => Matrix n k a ->+ Matrix k m a ->+ Matrix n m a+(<>) m1 m2 = map (<\> m2) m1++||| Tensor multiply (⊗) for ring matrices+(<&>) : Ring a => Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) (w1 * w2) a+(<&>) m1 m2 = zipWith (\&\) (stepOne m1 m2) (stepTwo m1 m2) where+ stepOne : Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) w1 a+ stepOne {h2} m1 m2 = concat $ map (replicate h2) m1+ stepTwo : Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) w2 a+ stepTwo {h1} m1 m2 = concat $ (Vect.replicate h1) m2++||| Cast a vector from a standard Vect to a proper n x 1 matrix+col : Vect n a -> Matrix n 1 a+col v = map (\x => [x]) v++||| Cast a row from a standard Vect to a proper 1 x n matrix+row : Vect n a -> Matrix 1 n a+row r = [r]++||| Outer product between ring vectors+(><) : Ring a => Vect n a -> Vect m a -> Matrix n m a+(><) x y = (col x) <> (row y)++||| All finite numbers up to the given bound+allN : (n : Nat) -> Vect n (Fin n)+allN Z = Nil+allN (S n) = FZ :: (map FS $ allN n)++||| Identity matrix+Id : RingWithUnity a => {d : Nat} -> Matrix d d a+Id {d} = map (\n => basis n) $ allN d++||| Matrix commutator+(<<>>) : Ring a => Matrix n n a -> Matrix n n a -> Matrix n n a+(<<>>) m1 m2 = (m1 <> m2) <-> (m2 <> m1)++||| Matrix anti-commutator+(>><<) : Ring a => Matrix n n a -> Matrix n n a -> Matrix n n a+(>><<) m1 m2 = (m1 <> m2) <+> (m2 <> m1)++-----------------------------------------------------------------------+-- Matrix Algebra Properties+-----------------------------------------------------------------------++-- 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/Rel.idr view
@@ -0,0 +1,12 @@+module Data.Rel++import Data.Fun+++||| Build an n-ary relation type from a Vect of Types+Rel : Vect n Type -> Type+Rel ts = Fun ts Type++liftRel : (ts : Vect n Type) -> (p : Rel ts) -> (Type -> Type) -> Type+liftRel [] p f = f p+liftRel (t :: ts) p f = (x : t) -> liftRel ts (p x) f
+ libs/contrib/Data/Sign.idr view
@@ -0,0 +1,8 @@+module Data.Sign++||| A representation of signs for signed datatypes such as `ZZ`+data Sign = Plus | Zero | Minus++||| Discover the sign of some type+class Signed t where+ total sign : t -> Sign
+ libs/contrib/Data/SortedMap.idr view
@@ -0,0 +1,237 @@+module Data.SortedMap++-- 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++branch4 :+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v ->+ Tree (S (S n)) k v+branch4 a b c d e f g =+ Branch2 (Branch2 a b c) d (Branch2 e f g)++branch5 :+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v ->+ Tree (S (S n)) k v+branch5 a b c d e f g h i =+ Branch2 (Branch2 a b c) d (Branch3 e f g h i)++branch6 :+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v ->+ Tree (S (S n)) k v+branch6 a b c d e f g h i j k =+ Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)++branch7 :+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v -> k ->+ Tree n k v ->+ Tree (S (S n)) k v+branch7 a b c d e f g h i j k l m =+ Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)++merge1 : Tree n k v -> k -> Tree (S n) k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v+merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i+merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k+merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k+merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m++merge2 : Tree (S n) k v -> k -> Tree n k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v+merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i+merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k+merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k+merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m++merge3 : Tree (S n) k v -> k -> Tree (S n) k v -> k -> Tree n k v -> Tree (S (S n)) k v+merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i+merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k+merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k+merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m++treeLookup : Ord k => k -> Tree n k v -> Maybe v+treeLookup k (Leaf k' v) =+ if k == k' then+ Just v+ else+ Nothing+treeLookup k (Branch2 t1 k' t2) =+ if k <= k' then+ treeLookup k t1+ else+ treeLookup k t2+treeLookup k (Branch3 t1 k1 t2 k2 t3) =+ if k <= k1 then+ treeLookup k t1+ else if k <= k2 then+ treeLookup k t2+ else+ treeLookup k t3++treeInsert' : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree n k v, k, Tree n k v)+treeInsert' k v (Leaf k' v') =+ case compare k k' of+ LT => Right (Leaf k v, k, Leaf k' v')+ EQ => Left (Leaf k v)+ GT => Right (Leaf k' v', k', Leaf k v)+treeInsert' k v (Branch2 t1 k' t2) =+ if k <= k' then+ case treeInsert' k v t1 of+ Left t1' => Left (Branch2 t1' k' t2)+ Right (a, b, c) => Left (Branch3 a b c k' t2)+ else+ case treeInsert' k v t2 of+ Left t2' => Left (Branch2 t1 k' t2')+ Right (a, b, c) => Left (Branch3 t1 k' a b c)+treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =+ if k <= k1 then+ case treeInsert' k v t1 of+ Left t1' => Left (Branch3 t1' k1 t2 k2 t3)+ Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3)+ else+ if k <= k2 then+ case treeInsert' k v t2 of+ Left t2' => Left (Branch3 t1 k1 t2' k2 t3)+ Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3)+ else+ case treeInsert' k v t3 of+ Left t3' => Left (Branch3 t1 k1 t2 k2 t3')+ Right (a, b, c) => Right (Branch2 t1 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 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++treeDelete : Ord k => k -> Tree n k v -> Either (Tree n k v) (delType n k v)+treeDelete k (Leaf k' v) =+ if k == k' then+ Right ()+ else+ Left (Leaf k' v)+treeDelete {n=S Z} k (Branch2 t1 k' t2) =+ if k <= k' then+ case treeDelete k t1 of+ Left t1' => Left (Branch2 t1' k' t2)+ Right () => Right t2+ else+ case treeDelete k t2 of+ Left t2' => Left (Branch2 t1 k' t2')+ Right () => Right t1+treeDelete {n=S Z} k (Branch3 t1 k1 t2 k2 t3) =+ if k <= k1 then+ case treeDelete k t1 of+ Left t1' => Left (Branch3 t1' k1 t2 k2 t3)+ Right () => Left (Branch2 t2 k2 t3)+ else if k <= k2 then+ case treeDelete k t2 of+ Left t2' => Left (Branch3 t1 k1 t2' k2 t3)+ Right () => Left (Branch2 t1 k1 t3)+ else+ case treeDelete k t3 of+ Left t3' => Left (Branch3 t1 k1 t2 k2 t3')+ Right () => Left (Branch2 t1 k1 t2)+treeDelete {n=S (S _)} k (Branch2 t1 k' t2) =+ if k <= k' then+ case treeDelete k t1 of+ Left t1' => Left (Branch2 t1' k' t2)+ Right t1' =>+ case t2 of+ Branch2 a b c => Right (Branch3 t1' k' a b c)+ Branch3 a b c d e => Left (branch4 t1' k' a b c d e)+ else+ case treeDelete k t2 of+ Left t2' => Left (Branch2 t1 k' t2')+ Right t2' =>+ case t1 of+ Branch2 a b c => Right (Branch3 a b c k' t2')+ Branch3 a b c d e => Left (branch4 a b c d e k' t2')+treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) =+ if k <= k1 then+ case treeDelete k t1 of+ Left t1' => Left (Branch3 t1' k1 t2 k2 t3)+ Right t1' => Left (merge1 t1' k1 t2 k2 t3)+ else if k <= k2 then+ case treeDelete k t2 of+ Left t2' => Left (Branch3 t1 k1 t2' k2 t3)+ Right t2' => Left (merge2 t1 k1 t2' k2 t3)+ else+ case treeDelete k t3 of+ Left t3' => Left (Branch3 t1 k1 t2 k2 t3')+ Right t3' => Left (merge3 t1 k1 t2 k2 t3')++treeToList : Tree n k v -> List (k, v)+treeToList = treeToList' (:: [])+ where+ treeToList' : ((k, v) -> List (k, v)) -> Tree n k v -> 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++data SortedMap : Type -> Type -> Type where+ Empty : SortedMap k v+ M : (n:Nat) -> Tree n k v -> SortedMap k v++empty : SortedMap k v+empty = Empty++lookup : Ord k => k -> SortedMap k v -> Maybe v+lookup _ Empty = Nothing+lookup k (M _ t) = treeLookup k t++insert : Ord k => k -> v -> SortedMap k v -> SortedMap k v+insert k v Empty = M 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+delete _ Empty = Empty+delete k (M Z t) =+ case treeDelete k t of+ Left t' => (M _ t')+ Right () => Empty+delete k (M (S _) t) =+ case treeDelete k t of+ Left t' => (M _ t')+ Right t' => (M _ t')++fromList : Ord k => List (k, v) -> SortedMap k v+fromList l = foldl (flip (uncurry insert)) empty l++toList : 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)++instance Functor (SortedMap k) where+ map _ Empty = Empty+ map f (M n t) = M _ (map f t)
+ libs/contrib/Data/SortedSet.idr view
@@ -0,0 +1,28 @@+module Data.SortedSet++import Data.SortedMap++-- TODO: add intersection, union, difference++data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ())++empty : SortedSet k+empty = SetWrapper Data.SortedMap.empty++insert : Ord k => k -> SortedSet k -> SortedSet k+insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m)++delete : Ord k => k -> SortedSet k -> SortedSet k+delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m)++contains : Ord k => k -> SortedSet k -> Bool+contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)++fromList : Ord k => List k -> SortedSet k+fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l))++toList : SortedSet k -> List k+toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)++instance Foldable SortedSet where+ foldr f e xs = foldr f e (Data.SortedSet.toList xs)
+ libs/contrib/Data/ZZ.idr view
@@ -0,0 +1,154 @@+module Data.ZZ++import Decidable.Equality+import Data.Sign++%default total+%access public+++||| An integer is either a positive `Nat` or the negated successor of a `Nat`.+|||+||| For example, 3 is `Pos 3` and -2 is `NegS 1`. Zero is arbitrarily chosen+||| to be positive.+|||+data ZZ = Pos Nat | NegS Nat++instance Signed ZZ where+ sign (Pos Z) = Zero+ sign (Pos _) = Plus+ sign (NegS _) = Minus++||| Take the absolute value of a `ZZ`+absZ : ZZ -> Nat+absZ (Pos n) = n+absZ (NegS n) = S n++instance Show ZZ where+ show (Pos n) = show n+ show (NegS n) = "-" ++ show (S n)++instance Neg ZZ where+ negate (Pos Z) = Pos Z+ negate (Pos (S n)) = NegS n+ negate (NegS n) = Pos (S n)++negNat : Nat -> ZZ+negNat Z = Pos Z+negNat (S n) = NegS n+++||| Construct a `ZZ` as the difference of two `Nat`s+minusNatZ : Nat -> Nat -> ZZ+minusNatZ n Z = Pos n+minusNatZ Z (S m) = NegS m+minusNatZ (S n) (S m) = minusNatZ n m++||| Add two `ZZ`s. Consider using `(+) {a=ZZ}`.+plusZ : ZZ -> ZZ -> ZZ+plusZ (Pos n) (Pos m) = Pos (n + m)+plusZ (NegS n) (NegS m) = NegS (S (n + m))+plusZ (Pos n) (NegS m) = minusNatZ n (S m)+plusZ (NegS n) (Pos m) = minusNatZ m (S n)++||| Subtract two `ZZ`s. Consider using `(-) {a=ZZ}`.+subZ : ZZ -> ZZ -> ZZ+subZ n m = plusZ n (negate m)++instance Eq ZZ where+ (Pos n) == (Pos m) = n == m+ (NegS n) == (NegS m) = n == m+ _ == _ = False+++instance Ord ZZ where+ compare (Pos n) (Pos m) = compare n m+ compare (NegS n) (NegS m) = compare m n+ compare (Pos _) (NegS _) = GT+ compare (NegS _) (Pos _) = LT++||| Multiply two `ZZ`s. Consider using `(*) {a=ZZ}`.+multZ : ZZ -> ZZ -> ZZ+multZ (Pos n) (Pos m) = Pos $ n * m+multZ (NegS n) (NegS m) = Pos $ (S n) * (S m)+multZ (NegS n) (Pos m) = negNat $ (S n) * m+multZ (Pos n) (NegS m) = negNat $ n * (S m)++||| Convert an `Integer` to an inductive representation.+fromInt : Integer -> ZZ+fromInt n = if n < 0+ then NegS $ fromInteger {a=Nat} ((-n) - 1)+ else Pos $ fromInteger {a=Nat} n++instance Cast Nat ZZ where+ cast n = Pos n++instance Num ZZ where+ (+) = plusZ+ (-) = subZ+ (*) = multZ+ abs = cast . absZ+ fromInteger = fromInt++instance Cast ZZ Integer where+ cast (Pos n) = cast n+ cast (NegS n) = (-1) * (cast n + 1)++instance Cast Integer ZZ where+ cast = fromInteger+++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++natPlusZPlus : (n : Nat) -> (m : Nat) -> (x : Nat)+ -> n + m = x -> (Pos n) + (Pos m) = Pos x+natPlusZPlus n m x h = cong h++natMultZMult : (n : Nat) -> (m : Nat) -> (x : Nat)+ -> n * m = x -> (Pos n) * (Pos m) = Pos x+natMultZMult n m x h = cong h++doubleNegElim : (z : ZZ) -> negate (negate z) = z+doubleNegElim (Pos Z) = Refl+doubleNegElim (Pos (S n)) = Refl+doubleNegElim (NegS Z) = Refl+doubleNegElim (NegS (S n)) = Refl++-- Injectivity+posInjective : Pos n = Pos m -> n = m+posInjective Refl = Refl++negSInjective : NegS n = NegS m -> n = m+negSInjective Refl = Refl++posNotNeg : Pos n = NegS m -> Void+posNotNeg Refl impossible++-- Decidable equality+instance DecEq ZZ where+ decEq (Pos n) (NegS m) = No posNotNeg+ decEq (NegS n) (Pos m) = No $ negEqSym posNotNeg+ decEq (Pos n) (Pos m) with (decEq n m)+ | Yes p = Yes $ cong p+ | No p = No $ \h => p $ posInjective h+ decEq (NegS n) (NegS m) with (decEq n m)+ | Yes p = Yes $ cong p+ | No p = No $ \h => p $ negSInjective h++-- Plus+plusZeroLeftNeutralZ : (right : ZZ) -> 0 + right = right+plusZeroLeftNeutralZ (Pos n) = Refl+plusZeroLeftNeutralZ (NegS n) = Refl++plusZeroRightNeutralZ : (left : ZZ) -> left + 0 = left+plusZeroRightNeutralZ (Pos n) = cong $ plusZeroRightNeutral n+plusZeroRightNeutralZ (NegS n) = Refl++plusCommutativeZ : (left : ZZ) -> (right : ZZ) -> (left + right = right + left)+plusCommutativeZ (Pos n) (Pos m) = cong $ plusCommutative n m+plusCommutativeZ (Pos n) (NegS m) = Refl+plusCommutativeZ (NegS n) (Pos m) = Refl+plusCommutativeZ (NegS n) (NegS m) = cong {f=NegS} $ cong {f=S} $ plusCommutative n m+
+ libs/contrib/Decidable/Decidable.idr view
@@ -0,0 +1,23 @@+module Decidable.Decidable++import Data.Rel+import Data.Fun++%access public++--------------------------------------------------------------------------------+-- Typeclass for decidable n-ary Relations+--------------------------------------------------------------------------------++-- Note: Instance resolution for Decidable is likely to not work in the REPL+-- at the moment.+class Decidable (ts : Vect k Type) (p : Rel ts) where+ total decide : liftRel ts p Dec++-- 'No such variable {k506}'+--decision : Decidable ts p => (ts : Vect k Type) -> (p : Rel ts) -> liftRel ts p Dec+--decision ts p = decide {ts} {p}++using (a : Type, x : a)+ data Given : Dec a -> Type where+ Always : Given (Yes x)
+ libs/contrib/Decidable/Order.idr view
@@ -0,0 +1,156 @@+module Decidable.Order++import Decidable.Decidable+import Decidable.Equality+import Data.Fin+import Data.Fun+import Data.Rel++%access public++--------------------------------------------------------------------------------+-- Utility Lemmas+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- Preorders, Posets, total Orders, Equivalencies, Congruencies+--------------------------------------------------------------------------------++class Preorder t (po : t -> t -> Type) where+ total transitive : (a : t) -> (b : t) -> (c : t) -> po a b -> po b c -> po a c+ total reflexive : (a : t) -> po a a++class (Preorder t po) => Poset t (po : t -> t -> Type) where+ total antisymmetric : (a : t) -> (b : t) -> po a b -> po b a -> a = b++class (Poset t to) => Ordered t (to : t -> t -> Type) where+ total order : (a : t) -> (b : t) -> Either (to a b) (to b a)++class (Preorder t eq) => Equivalence t (eq : t -> t -> Type) where+ total symmetric : (a : t) -> (b : t) -> eq a b -> eq b a++class (Equivalence t eq) => Congruence t (f : t -> t) (eq : t -> t -> Type) where+ total congruent : (a : t) -> + (b : t) -> + eq a b -> + eq (f a) (f b)++minimum : (Ordered t to) => t -> t -> t+minimum {to} x y with (order {to} x y)+ | Left _ = x+ | Right _ = y++maximum : (Ordered t to) => t -> t -> t+maximum {to} x y with (order {to} x y)+ | Left _ = y+ | Right _ = x++--------------------------------------------------------------------------------+-- Syntactic equivalence (=)+--------------------------------------------------------------------------------++instance Preorder t ((=) {A = t} {B = t}) where+ transitive a b c = trans {a = a} {b = b} {c = c}+ reflexive a = Refl++instance Equivalence t ((=) {A = t} {B = t}) where+ symmetric a b prf = sym prf++instance Congruence t f ((=) {A = t} {B = t}) where+ congruent a b = cong {a = a} {b = b} {f = f}++--------------------------------------------------------------------------------+-- Natural numbers+--------------------------------------------------------------------------------++total LTEIsTransitive : (m : Nat) -> (n : Nat) -> (o : Nat) ->+ LTE m n -> LTE n o ->+ LTE m o+LTEIsTransitive Z n o LTEZero nlteo = LTEZero+LTEIsTransitive (S m) (S n) (S o) (LTESucc mlten) (LTESucc nlteo) = LTESucc (LTEIsTransitive m n o mlten nlteo)++total LTEIsReflexive : (n : Nat) -> LTE n n+LTEIsReflexive Z = LTEZero+LTEIsReflexive (S n) = LTESucc (LTEIsReflexive n)++instance Preorder Nat LTE where+ transitive = LTEIsTransitive+ reflexive = LTEIsReflexive++total LTEIsAntisymmetric : (m : Nat) -> (n : Nat) ->+ LTE m n -> LTE n m -> m = n+LTEIsAntisymmetric Z Z LTEZero LTEZero = Refl+LTEIsAntisymmetric (S n) (S m) (LTESucc mLTEn) (LTESucc nLTEm) with (LTEIsAntisymmetric n m mLTEn nLTEm)+ LTEIsAntisymmetric (S n) (S n) (LTESucc mLTEn) (LTESucc nLTEm) | Refl = Refl +++instance Poset Nat LTE where+ antisymmetric = LTEIsAntisymmetric++total zeroNeverGreater : {n : Nat} -> LTE (S n) Z -> Void+zeroNeverGreater {n} LTEZero impossible+zeroNeverGreater {n} (LTESucc _) impossible++total zeroAlwaysSmaller : {n : Nat} -> LTE Z n+zeroAlwaysSmaller = LTEZero++total ltesuccinjective : {n : Nat} -> {m : Nat} -> (LTE n m -> Void) -> LTE (S n) (S m) -> Void+ltesuccinjective {n} {m} disprf (LTESucc nLTEm) = void (disprf nLTEm)+ltesuccinjective {n} {m} disprf LTEZero impossible+++total decideLTE : (n : Nat) -> (m : Nat) -> Dec (LTE n m)+decideLTE Z y = Yes LTEZero+decideLTE (S x) Z = No zeroNeverGreater+decideLTE (S x) (S y) with (decEq (S x) (S y))+ | Yes eq = rewrite eq in Yes (reflexive (S y))+ | No _ with (decideLTE x y)+ | Yes nLTEm = Yes (LTESucc nLTEm)+ | No nGTm = No (ltesuccinjective nGTm)++instance Decidable [Nat,Nat] LTE where+ decide = decideLTE++total+lte : (m : Nat) -> (n : Nat) -> Dec (LTE m n)+lte m n = decide {ts = [Nat,Nat]} {p = LTE} m n++total+shift : (m : Nat) -> (n : Nat) -> LTE m n -> LTE (S m) (S n)+shift m n mLTEn = LTESucc mLTEn+ +instance Ordered Nat LTE where+ order Z n = Left LTEZero+ order m Z = Right LTEZero+ order (S k) (S j) with (order {to=LTE} k j)+ order (S k) (S j) | Left prf = Left (shift k j prf)+ order (S k) (S j) | Right prf = Right (shift j k prf)++----------------------------------------------------------------------------------+---- Finite numbers+----------------------------------------------------------------------------------++using (k : Nat)+ data FinLTE : Fin k -> Fin k -> Type where+ FromNatPrf : {m : Fin k} -> {n : Fin k} -> LTE (finToNat m) (finToNat n) -> FinLTE m n++ instance Preorder (Fin k) FinLTE where+ transitive m n o (FromNatPrf p1) (FromNatPrf p2) = + FromNatPrf (LTEIsTransitive (finToNat m) (finToNat n) (finToNat o) p1 p2)+ reflexive n = FromNatPrf (LTEIsReflexive (finToNat n))++ instance Poset (Fin k) FinLTE where+ antisymmetric m n (FromNatPrf p1) (FromNatPrf p2) =+ finToNatInjective m n (LTEIsAntisymmetric (finToNat m) (finToNat n) p1 p2)+ + instance Decidable [Fin k, Fin k] FinLTE where+ decide m n with (decideLTE (finToNat m) (finToNat n))+ | Yes prf = Yes (FromNatPrf prf)+ | No disprf = No (\ (FromNatPrf prf) => disprf prf)++ instance Ordered (Fin k) FinLTE where+ order m n =+ either (Left . FromNatPrf) + (Right . FromNatPrf)+ (order (finToNat m) (finToNat n))+
+ libs/contrib/Makefile view
@@ -0,0 +1,24 @@+IDRIS := idris+PKG := contrib++build:+ $(IDRIS) --build ${PKG}.ipkg++install: + $(IDRIS) --install ${PKG}.ipkg++clean:+ $(IDRIS) --clean ${PKG}.ipkg++rebuild: clean build++doc:+ ${IDRIS} --mkdoc ${PKG}.ipkg++doc_clean:+ rm -rf ${PKG}_doc++linecount:+ find . -name '*.idr' | xargs wc -l++.PHONY: build install clean rebuild linecount
+ libs/contrib/Network/Cgi.idr view
@@ -0,0 +1,143 @@+module Network.Cgi++import System++%default total++public+Vars : Type+Vars = List (String, String)++record CGIInfo : Type where+ CGISt : (GET : Vars) ->+ (POST : Vars) ->+ (Cookies : Vars) ->+ (UserAgent : String) ->+ (Headers : String) ->+ (Output : String) -> CGIInfo++add_Headers : String -> CGIInfo -> CGIInfo+add_Headers str st = record { Headers = Headers st ++ str } st++add_Output : String -> CGIInfo -> CGIInfo+add_Output str st = record { Output = Output st ++ str } st++abstract+data CGI : Type -> Type where+ MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a++getAction : CGI a -> CGIInfo -> IO (a, CGIInfo)+getAction (MkCGI act) = act++instance Functor CGI where+ map f (MkCGI c) = MkCGI (\s => do (a, i) <- c s+ return (f a, i))++instance Applicative CGI where+ pure v = MkCGI (\s => return (v, s))++ (MkCGI a) <*> (MkCGI b) = MkCGI (\s => do (f, i) <- a s+ (c, j) <- b i+ return (f c, j))++instance Monad CGI where {+ (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s+ getAction (k (fst v)) (snd v))+}++setInfo : CGIInfo -> CGI ()+setInfo i = MkCGI (\s => return ((), i))++getInfo : CGI CGIInfo+getInfo = MkCGI (\s => return (s, s))++abstract+lift : IO a -> CGI a+lift op = MkCGI (\st => do { x <- op+ return (x, st) } )++abstract+output : String -> CGI ()+output s = do i <- getInfo+ setInfo (add_Output s i)++abstract+queryVars : CGI Vars+queryVars = do i <- getInfo+ return (GET i)++abstract+postVars : CGI Vars+postVars = do i <- getInfo+ return (POST i)++abstract+cookieVars : CGI Vars+cookieVars = do i <- getInfo+ return (Cookies i)++abstract+queryVar : String -> CGI (Maybe String)+queryVar x = do vs <- queryVars+ return (lookup x vs)++getOutput : CGI String+getOutput = do i <- getInfo+ return (Output i)++getHeaders : CGI String+getHeaders = do i <- getInfo+ return (Headers i)++abstract+flushHeaders : CGI ()+flushHeaders = do o <- getHeaders+ lift (putStrLn o)++abstract+flush : CGI ()+flush = do o <- getOutput+ lift (putStr o)++getVars : List Char -> String -> List (String, String)+getVars seps query = mapMaybe readVar (split (\x => elem x seps) query)+ where+ readVar : String -> Maybe (String, String)+ readVar xs with (split (\x => x == '=') xs)+ | [k, v] = Just (trim k, trim v)+ | _ = Nothing++getContent : Int -> IO String+getContent x = getC (toNat x) "" where+ getC : Nat -> String -> IO String+ getC Z acc = return $ reverse acc+ getC (S k) acc = do x <- getChar+ getC k (strCons x acc)++getCgiEnv : String -> IO String+getCgiEnv key = do+ val <- getEnv key+ return $ maybe "" id val++abstract+runCGI : CGI a -> IO a+runCGI prog = do+ clen_in <- getCgiEnv "CONTENT_LENGTH"+ let clen = prim__fromStrInt clen_in+ content <- getContent clen+ query <- getCgiEnv "QUERY_STRING"+ cookie <- getCgiEnv "HTTP_COOKIE"+ agent <- getCgiEnv "HTTP_USER_AGENT"++ let get_vars = getVars ['&',';'] query+ let post_vars = getVars ['&'] content+ let cookies = getVars [';'] cookie++ (v, st) <- getAction prog (CGISt get_vars post_vars cookies agent+ "Content-type: text/html\n"+ "")+ putStrLn (Headers st)+ putStr (Output st)+ return v++
+ libs/contrib/Network/Socket.idr view
@@ -0,0 +1,370 @@+-- Time to do this properly.+-- Low-Level C Sockets bindings for Idris. Used by higher-level, cleverer things.+-- (C) SimonJF, MIT Licensed, 2014+module IdrisNet.Socket++%include C "idris_net.h"+%include C "sys/types.h"+%include C "sys/socket.h"+%include C "netdb.h"++%access public++ByteLength : Type+ByteLength = Int++class ToCode a where+ toCode : a -> Int++||| Socket Families+|||+||| The ones that people might actually use. We're not going to need US+||| Government proprietary ones.+data SocketFamily =+ ||| Unspecified+ AF_UNSPEC |+ ||| IP / UDP etc. IPv4+ AF_INET |+ ||| IP / UDP etc. IPv6+ AF_INET6++instance Show SocketFamily where+ show AF_UNSPEC = "AF_UNSPEC"+ show AF_INET = "AF_INET"+ show AF_INET6 = "AF_INET6"++instance ToCode SocketFamily where+ toCode AF_UNSPEC = 0+ toCode AF_INET = 2+ toCode AF_INET6 = 10++getSocketFamily : Int -> Maybe SocketFamily+getSocketFamily i = Prelude.List.lookup i [(0, AF_UNSPEC), (2, AF_INET), (10, AF_INET6)]++||| Socket Types.+data SocketType =+ ||| Not a socket, used in certain operations+ NotASocket |+ ||| TCP+ Stream |+ ||| UDP+ Datagram |+ ||| Raw sockets+ RawSocket++instance Show SocketType where+ show NotASocket = "Not a socket"+ show Stream = "Stream"+ show Datagram = "Datagram"+ show RawSocket = "Raw"++instance ToCode SocketType where+ toCode NotASocket = 0+ toCode Stream = 1+ toCode Datagram = 2+ toCode RawSocket = 3+++data RecvStructPtr = RSPtr Ptr+data RecvfromStructPtr = RFPtr Ptr+data BufPtr = BPtr Ptr+data SockaddrPtr = SAPtr Ptr++||| Protocol Number.+|||+||| Generally good enough to just set it to 0.+ProtocolNumber : Type+ProtocolNumber = Int++||| SocketError: Error thrown by a socket operation+SocketError : Type+SocketError = Int++||| SocketDescriptor: Native C Socket Descriptor+SocketDescriptor : Type+SocketDescriptor = Int++data SocketAddress = IPv4Addr Int Int Int Int+ | IPv6Addr -- Not implemented (yet)+ | Hostname String+ | InvalidAddress -- Used when there's a parse error++instance Show SocketAddress where+ show (IPv4Addr i1 i2 i3 i4) = concat $ Prelude.List.intersperse "." (map show [i1, i2, i3, i4])+ show IPv6Addr = "NOT IMPLEMENTED YET"+ show (Hostname host) = host+ show InvalidAddress = "Invalid"++Port : Type+Port = Int++||| Backlog used within listen() call -- number of incoming calls+BACKLOG : Int+BACKLOG = 20++-- FIXME: This *must* be pulled in from C+EAGAIN : Int +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 UDPAddrInfo : Type where+ MkUDPAddrInfo : + (remote_addr : SocketAddress) ->+ (remote_port : Port) ->+ UDPAddrInfo++||| Frees a given pointer+public+sock_free : BufPtr -> IO ()+sock_free (BPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr++public+sockaddr_free : SockaddrPtr -> IO ()+sockaddr_free (SAPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr++||| Allocates an amount of memory given by the ByteLength parameter.+|||+||| Used to allocate a mutable pointer to be given to the Recv functions.+public+sock_alloc : ByteLength -> IO BufPtr+sock_alloc bl = map BPtr $ 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++||| Get the C error number+getErrno : IO Int+getErrno = foreign FFI_C "idrnet_errno" (IO Int)++||| Creates a UNIX socket with the given family, socket type and protocol+||| number. Returns either a socket or an error.+socket : SocketFamily -> SocketType -> ProtocolNumber -> IO (Either SocketError Socket)+socket sf st pn = do+ socket_res <- foreign FFI_C "socket" (Int -> Int -> Int -> IO Int) (toCode sf) (toCode st) pn+ if socket_res == -1 then -- error+ map Left getErrno+ else+ return $ Right (MkSocket socket_res sf st pn)++||| Close a socket+close : Socket -> IO ()+close sock = foreign FFI_C "close" (Int -> IO ()) (descriptor sock)++private+saString : (Maybe SocketAddress) -> String+saString (Just sa) = show sa+saString Nothing = ""++||| Binds a socket to the given socket address and port.+||| Returns 0 on success, an error code otherwise.+bind : Socket -> (Maybe SocketAddress) -> Port -> IO Int+bind sock addr port = do+ bind_res <- foreign FFI_C "idrnet_bind" + (Int -> Int -> Int -> String -> Int -> IO Int)+ (descriptor sock) (toCode $ family sock) + (toCode $ socketType sock) (saString addr) port+ if bind_res == (-1) then -- error+ getErrno+ else return 0 -- Success++||| Connects to a given address and port.+||| Returns 0 on success, and an error number on error.+connect : Socket -> SocketAddress -> Port -> IO Int+connect sock addr port = do+ conn_res <- foreign FFI_C "idrnet_connect"+ (Int -> Int -> Int -> String -> Int -> IO Int)+ (descriptor sock) (toCode $ family sock) (toCode $ socketType sock) (show addr) port+ if conn_res == (-1) then+ getErrno+ else return 0++||| Listens on a bound socket.+listen : Socket -> IO Int+listen sock = do+ listen_res <- foreign FFI_C "listen" (Int -> Int -> IO Int)+ (descriptor sock) BACKLOG+ if listen_res == (-1) then+ getErrno+ else return 0++||| Parses a textual representation of an IPv4 address into a SocketAddress+parseIPv4 : String -> SocketAddress+parseIPv4 str = case splitted of+ (i1 :: i2 :: i3 :: i4 :: _) => IPv4Addr i1 i2 i3 i4+ _ => InvalidAddress+ where toInt' : String -> Integer+ toInt' = cast+ toInt : String -> Int+ toInt s = fromInteger $ toInt' s+ splitted : List Int+ splitted = map toInt (Prelude.Strings.split (\c => c == '.') str)+++||| Retrieves a socket address from a sockaddr pointer+getSockAddr : SockaddrPtr -> IO SocketAddress+getSockAddr (SAPtr ptr) = do+ addr_family_int <- foreign FFI_C "idrnet_sockaddr_family" (Ptr -> IO Int) ptr+ -- putStrLn $ "Addr family int: " ++ (show addr_family_int)+ -- ASSUMPTION: Foreign call returns a valid int+ assert_total (case getSocketFamily addr_family_int of+ Just AF_INET => do+ ipv4_addr <- foreign FFI_C "idrnet_sockaddr_ipv4" (Ptr -> IO String) ptr+ return $ parseIPv4 ipv4_addr+ Just AF_INET6 => return IPv6Addr+ Just AF_UNSPEC => return InvalidAddress)++accept : Socket -> IO (Either SocketError (Socket, SocketAddress))+accept sock = do+ -- We need a pointer to a sockaddr structure. This is then passed into+ -- idrnet_accept and populated. We can then query it for the SocketAddr and free it.+ sockaddr_ptr <- foreign FFI_C "idrnet_create_sockaddr" (IO Ptr)+ accept_res <- foreign FFI_C "idrnet_accept" (Int -> Ptr -> IO Int) (descriptor sock) sockaddr_ptr+ if accept_res == (-1) then+ map Left getErrno+ else do+ let (MkSocket _ fam ty p_num) = sock+ sockaddr <- getSockAddr (SAPtr sockaddr_ptr)+ sockaddr_free (SAPtr sockaddr_ptr)+ return $ Right ((MkSocket accept_res fam ty p_num), sockaddr)++send : Socket -> String -> IO (Either SocketError ByteLength)+send sock dat = do+ send_res <- foreign FFI_C "idrnet_send" (Int -> String -> IO Int) (descriptor sock) dat+ if send_res == (-1) then+ map Left getErrno+ else+ return $ Right send_res+++freeRecvStruct : RecvStructPtr -> IO ()+freeRecvStruct (RSPtr p) = foreign FFI_C "idrnet_free_recv_struct" (Ptr -> IO ()) p++freeRecvfromStruct : RecvfromStructPtr -> IO ()+freeRecvfromStruct (RFPtr p) = foreign FFI_C "idrnet_free_recvfrom_struct" (Ptr -> IO ()) p++recv : Socket -> Int -> IO (Either SocketError (String, ByteLength))+recv sock len = do+ -- Firstly make the request, get some kind of recv structure which+ -- contains the result of the recv and possibly the retrieved payload+ recv_struct_ptr <- foreign FFI_C "idrnet_recv" (Int -> Int -> IO Ptr) (descriptor sock) len+ recv_res <- foreign FFI_C "idrnet_get_recv_res" (Ptr -> IO Int) recv_struct_ptr+ if recv_res == (-1) then do+ errno <- getErrno+ freeRecvStruct (RSPtr recv_struct_ptr)+ return $ Left errno+ else + if recv_res == 0 then do+ freeRecvStruct (RSPtr recv_struct_ptr)+ return $ Left 0+ else do+ payload <- foreign FFI_C "idrnet_get_recv_payload" (Ptr -> IO String) recv_struct_ptr+ freeRecvStruct (RSPtr recv_struct_ptr)+ return $ Right (payload, recv_res)+++||| Sends the data in a given memory location+sendBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)+sendBuf sock (BPtr ptr) len = do+ send_res <- foreign FFI_C "idrnet_send_buf" (Int -> Ptr -> Int -> IO Int) (descriptor sock) ptr len+ if send_res == (-1) then+ map Left getErrno+ else+ return $ Right send_res++recvBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)+recvBuf sock (BPtr ptr) len = do+ recv_res <- foreign FFI_C "idrnet_recv_buf" (Int -> Ptr -> Int -> IO Int) (descriptor sock) ptr len+ if (recv_res == (-1)) then+ map Left getErrno+ else+ return $ Right recv_res++sendTo : Socket -> SocketAddress -> Port -> String -> IO (Either SocketError ByteLength)+sendTo sock addr p dat = do+ sendto_res <- foreign FFI_C "idrnet_sendto" + (Int -> String -> String -> Int -> Int -> IO Int) + (descriptor sock) dat (show addr) p (toCode $ family sock)+ if sendto_res == (-1) then+ map Left getErrno+ else+ return $ Right sendto_res+++sendToBuf : Socket -> SocketAddress -> Port -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)+sendToBuf sock addr p (BPtr dat) len = do+ sendto_res <- foreign FFI_C "idrnet_sendto_buf" + (Int -> Ptr -> Int -> String -> Int -> Int -> IO Int) + (descriptor sock) dat len (show addr) p (toCode $ family sock)+ if sendto_res == (-1) then+ map Left getErrno+ else+ return $ Right sendto_res+++foreignGetRecvfromPayload : RecvfromStructPtr -> IO String+foreignGetRecvfromPayload (RFPtr p) + = foreign FFI_C "idrnet_get_recvfrom_payload" (Ptr -> IO String) p++foreignGetRecvfromAddr : RecvfromStructPtr -> IO SocketAddress+foreignGetRecvfromAddr (RFPtr p) = do+ sockaddr_ptr <- map SAPtr $ foreign FFI_C "idrnet_get_recvfrom_sockaddr" (Ptr -> IO Ptr) p+ getSockAddr sockaddr_ptr+++foreignGetRecvfromPort : RecvfromStructPtr -> IO Port+foreignGetRecvfromPort (RFPtr p) = do+ sockaddr_ptr <- foreign FFI_C "idrnet_get_recvfrom_sockaddr" (Ptr -> IO Ptr) p+ port <- foreign FFI_C "idrnet_sockaddr_ipv4_port" (Ptr -> IO Int) sockaddr_ptr+ return port++recvFrom : Socket -> ByteLength -> IO (Either SocketError (UDPAddrInfo, String, ByteLength))+recvFrom sock bl = do+ recv_ptr <- foreign FFI_C "idrnet_recvfrom" (Int -> Int -> IO Ptr) + (descriptor sock) bl+ let recv_ptr' = RFPtr recv_ptr+ if !(nullPtr recv_ptr) then+ map Left getErrno+ else do+ result <- foreign FFI_C "idrnet_get_recvfrom_res" (Ptr -> IO Int) recv_ptr+ if result == -1 then do+ freeRecvfromStruct recv_ptr'+ map Left getErrno+ else do+ payload <- foreignGetRecvfromPayload recv_ptr'+ port <- foreignGetRecvfromPort recv_ptr'+ addr <- foreignGetRecvfromAddr recv_ptr'+ freeRecvfromStruct recv_ptr'+ return $ Right (MkUDPAddrInfo addr port, payload, result)+++recvFromBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError (UDPAddrInfo, ByteLength))+recvFromBuf sock (BPtr ptr) bl = do+ recv_ptr <- foreign FFI_C "idrnet_recvfrom_buf" (Int -> Ptr -> Int -> IO Ptr) (descriptor sock) ptr bl+ let recv_ptr' = RFPtr recv_ptr+ if !(nullPtr recv_ptr) then+ map Left getErrno+ else do+ result <- foreign FFI_C "idrnet_get_recvfrom_res" (Ptr -> IO Int) recv_ptr+ if result == -1 then do+ freeRecvfromStruct recv_ptr'+ map Left getErrno+ else do+ port <- foreignGetRecvfromPort recv_ptr'+ addr <- foreignGetRecvfromAddr recv_ptr'+ freeRecvfromStruct recv_ptr'+ return $ Right (MkUDPAddrInfo addr port, result + 1)++
+ libs/contrib/System/Concurrency/Process.idr view
@@ -0,0 +1,72 @@+-- WARNING: No guarantees that this works properly yet!++module System.Concurrency.Process++import System.Concurrency.Raw++%access public++abstract+data ProcID msg = MkPID Ptr++||| Type safe message passing programs. Parameterised over the type of+||| message which can be send, and the return type.+data Process : (msgType : Type) -> Type -> Type where+ Lift : IO a -> Process msg a++instance Functor (Process msg) where+ map f (Lift a) = Lift (map f a)++instance Applicative (Process msg) where+ pure = Lift . return+ (Lift f) <*> (Lift a) = Lift (f <*> a)++instance Monad (Process msg) where+ (Lift io) >>= k = Lift (do x <- io+ case k x of+ Lift v => v)++run : Process msg x -> IO x+run (Lift prog) = prog++||| Get current process ID+myID : Process msg (ProcID msg)+myID = Lift (return (MkPID prim__vm))++||| Send a message to another process+send : ProcID msg -> msg -> Process msg ()+send (MkPID p) m = Lift (sendToThread p (prim__vm, m))++||| Return whether a message is waiting in the queue+msgWaiting : Process msg Bool+msgWaiting = Lift checkMsgs++||| Return whether a message is waiting in the queue from a specific sender+msgWaitingFrom : ProcID msg -> Process msg Bool+msgWaitingFrom (MkPID p) = Lift (checkMsgsFrom p)++||| Receive a message - blocks if there is no message waiting+recv : Process msg msg+recv {msg} = do (senderid, m) <- Lift get+ return m+ where get : IO (Ptr, msg)+ get = getMsg++||| Receive a message from specific sender - blocks if there is no message waiting+recvFrom : ProcID msg -> Process msg msg+recvFrom (MkPID p) {msg} = do (senderid, m) <- Lift get+ return m+ where get : IO (Ptr, msg)+ get = getMsgFrom p++||| receive a message, and return with the sender's process ID.+recvWithSender : Process msg (ProcID msg, msg)+recvWithSender {msg}+ = do (senderid, m) <- Lift get+ return (MkPID senderid, m)+ where get : IO (Ptr, msg)+ get = getMsg++create : Process msg () -> Process msg (ProcID msg)+create (Lift p) = do ptr <- Lift (fork p)+ return (MkPID ptr)
+ libs/contrib/contrib.ipkg view
@@ -0,0 +1,18 @@+package contrib++opts = "--nobasepkgs --total -i ../prelude -i ../base"+modules = Control.Algebra,+ Control.Isomorphism.Primitives,+ Classes.Verified,+ Data.Fun, Data.Rel, Data.Buffer,+ Data.Hash, Data.Matrix,+ Data.ZZ, Data.Sign,+ Data.BoundedList,+ Data.Heap,+ Data.SortedMap, Data.SortedSet,++ Decidable.Decidable, Decidable.Order,++ Network.Cgi, Network.Socket,++ System.Concurrency.Process
libs/effects/Effect/Exception.idr view
@@ -4,7 +4,7 @@ import System import Control.IOExcept -data Exception : Type -> Effect where +data Exception : Type -> Effect where Raise : a -> { () } Exception a b instance Handler (Exception a) Maybe where@@ -14,7 +14,7 @@ handle _ (Raise e) k = [] instance Show a => Handler (Exception a) IO where- handle _ (Raise e) k = do print e+ handle _ (Raise e) k = do printLn e believe_me (exit 1) instance Handler (Exception a) (IOExcept a) where@@ -26,7 +26,7 @@ EXCEPTION : Type -> EFFECT EXCEPTION t = MkEff () (Exception t) -raise : a -> { [EXCEPTION a ] } Eff b +raise : a -> { [EXCEPTION a ] } Eff b raise err = call $ Raise err @@ -39,4 +39,3 @@ -- possibly add a 'handle' to the Eff language so that an alternative -- handler can be introduced mid interpretation?-
libs/effects/Effect/Memory.idr view
@@ -24,11 +24,11 @@ (size : Nat) -> So (offset + size <= i) -> RawMemory (Vect size Bits8)- (MemoryChunk n i) (\v => MemoryChunk n i) + (MemoryChunk n i) (\v => MemoryChunk n i) Poke : (offset : Nat) -> (Vect size Bits8) -> So (offset <= i && offset + size <= n) ->- RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size))) + RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size))) Move : (src : MemoryChunk src_size src_init) -> (dst_offset : Nat) -> (src_offset : Nat) ->@@ -36,13 +36,13 @@ So (dst_offset <= dst_init && dst_offset + size <= dst_size) -> So (src_offset + size <= src_init) -> RawMemory () (MemoryChunk dst_size dst_init)- (\v => MemoryChunk dst_size (max dst_init (dst_offset + size))) - GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i) + (\v => MemoryChunk dst_size (max dst_init (dst_offset + size)))+ GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i) private do_malloc : Nat -> IOExcept String Ptr do_malloc size with (fromInteger (cast size) == size)- | True = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (fromInteger $ cast size)+ | True = do ptr <- ioe_lift $ foreign FFI_C "malloc" (Int -> IO Ptr) (fromInteger $ cast size) fail <- ioe_lift $ nullPtr ptr if fail then ioe_fail "Cannot allocate memory" else return ptr@@ -51,24 +51,24 @@ private do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO () do_memset ptr offset c size- = mkForeign (FFun "idris_memset" [FPtr, FInt, FByte, FInt] FUnit)+ = foreign FFI_C "idris_memset" (Ptr -> Int -> Bits8 -> Int -> IO ()) ptr (fromInteger $ cast offset) c (fromInteger $ cast size) private do_free : Ptr -> IO ()-do_free ptr = mkForeign (FFun "free" [FPtr] FUnit) ptr+do_free ptr = foreign FFI_C "free" (Ptr -> IO ()) ptr private do_memmove : Ptr -> Ptr -> Nat -> Nat -> Nat -> IO () do_memmove dest src dest_offset src_offset size- = mkForeign (FFun "idris_memmove" [FPtr, FPtr, FInt, FInt, FInt] FUnit)- dest src (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size)+ = foreign FFI_C "idris_memmove" (Ptr -> Ptr -> Int -> Int -> Int -> IO ())+ dest src (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size) private do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8) do_peek _ _ Z = return (Vect.Nil) do_peek ptr offset (S n)- = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FByte) ptr (fromInteger $ cast offset)+ = do b <- foreign FFI_C "idris_peek" (Ptr -> Int -> IO Bits8) ptr (fromInteger $ cast offset) bs <- do_peek ptr (S offset) n Monad.return (Vect.(::) b bs) @@ -76,7 +76,7 @@ do_poke : Ptr -> Nat -> Vect size Bits8 -> IO () do_poke _ _ [] = return () do_poke ptr offset (b::bs)- = do mkForeign (FFun "idris_poke" [FPtr, FInt, FByte] FUnit) ptr (fromInteger $ cast offset) b+ = do foreign FFI_C "idris_poke" (Ptr -> Int -> Bits8 -> IO ()) ptr (fromInteger $ cast offset) b do_poke ptr (S offset) bs instance Handler RawMemory (IOExcept String) where@@ -84,9 +84,9 @@ = do ptr <- do_malloc n k () (CH ptr) handle {-{res = MemoryChunk _ offset}-} (CH ptr) (Initialize {i} c size _) k- = ioe_lift (do_memset ptr i c size) $> k () (CH ptr)+ = ioe_lift (do_memset ptr i c size) *> k () (CH ptr) handle (CH ptr) (Free) k- = ioe_lift (do_free ptr) $> k () ()+ = ioe_lift (do_free ptr) *> k () () handle (CH ptr) (Peek offset size _) k = do res <- ioe_lift (do_peek ptr offset size) k res (CH ptr)@@ -102,7 +102,7 @@ RAW_MEMORY : Type -> EFFECT RAW_MEMORY t = MkEff t RawMemory -allocate : (n : Nat) -> +allocate : (n : Nat) -> Eff () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)]) allocate size = call $ Allocate size @@ -111,7 +111,7 @@ Bits8 -> (size : Nat) -> So (i + size <= n) ->- Eff () [RAW_MEMORY (MemoryChunk n i)] + Eff () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY (MemoryChunk n (i + size))]) initialize c size prf = call $ Initialize c size prf @@ -122,7 +122,7 @@ (offset : Nat) -> (size : Nat) -> So (offset + size <= i) ->- { [RAW_MEMORY (MemoryChunk n i)] } Eff (Vect size Bits8) + { [RAW_MEMORY (MemoryChunk n i)] } Eff (Vect size Bits8) peek offset size prf = call $ Peek offset size prf poke : {n : Nat} ->@@ -130,12 +130,12 @@ (offset : Nat) -> Vect size Bits8 -> So (offset <= i && offset + size <= n) ->- Eff () [RAW_MEMORY (MemoryChunk n i)] + Eff () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))]) poke offset content prf = call $ Poke offset content prf private-getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff (MemoryChunk n i) +getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff (MemoryChunk n i) getRawPtr = call $ GetRawPtr private@@ -173,5 +173,5 @@ move dst_offset src_offset size dst_bounds src_bounds = do src_ptr <- Src :- getRawPtr Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds- return () + return ()
libs/effects/Effect/Monad.idr view
@@ -11,7 +11,7 @@ instance Applicative (\a => EffM m a xs (\v => xs)) where pure = value- (<$>) f a = do f' <- f+ (<*>) f a = do f' <- f a' <- a value (f' a')
libs/effects/Effect/StdIO.idr view
@@ -9,8 +9,8 @@ ||| The internal representation of StdIO effects data StdIO : Effect where- PutStr : String -> { () } StdIO () - GetStr : { () } StdIO String + PutStr : String -> { () } StdIO ()+ GetStr : { () } StdIO String PutCh : Char -> { () } StdIO () GetCh : { () } StdIO Char @@ -22,13 +22,13 @@ instance Handler StdIO IO where handle () (PutStr s) k = do putStr s; k () () handle () GetStr k = do x <- getLine; k x ()- handle () (PutCh c) k = do putChar c; k () () + handle () (PutCh c) k = do putChar c; k () () handle () GetCh k = do x <- getChar; k x () instance Handler StdIO (IOExcept a) where handle () (PutStr s) k = do ioe_lift $ putStr s; k () () handle () GetStr k = do x <- ioe_lift $ getLine; k x ()- handle () (PutCh c) k = do ioe_lift $ putChar c; k () () + handle () (PutCh c) k = do ioe_lift $ putChar c; k () () handle () GetCh k = do x <- ioe_lift $ getChar; k x () -------------------------------------------------------------@@ -42,13 +42,17 @@ putStr : String -> { [STDIO] } Eff () putStr s = call $ PutStr s +||| Write a string to standard output, terminating with a newline.+putStrLn : String -> { [STDIO] } Eff ()+putStrLn s = putStr (s ++ "\n")+ ||| Write a character to standard output. putChar : Char -> { [STDIO] } Eff () putChar c = call $ PutCh c -||| Write a string to standard output, terminating with a newline.-putStrLn : String -> { [STDIO] } Eff ()-putStrLn s = putStr (s ++ "\n")+||| Write a character to standard output, terminating with a newline.+putCharLn : Char -> { [STDIO] } Eff ()+putCharLn c = putStrLn (singleton c) ||| Read a string from standard input. getStr : { [STDIO] } Eff String@@ -58,3 +62,10 @@ getChar : { [STDIO] } Eff Char getChar = call $ GetCh +||| Given a parameter `a` 'show' `a` to standard output.+print : Show a => a -> { [STDIO] } Eff ()+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 a = putStrLn (show a)
libs/effects/Effects.idr view
@@ -174,7 +174,7 @@ -- ------------------------------------------------------ [ for idiom brackets ] -infixl 2 <$>+infixl 2 <*> pure : a -> Eff a xs (\v => xs) pure = value@@ -182,9 +182,9 @@ pureM : (val : a) -> Eff a (xs val) xs pureM = value -(<$>) : Eff (a -> b) xs (\v => xs) ->+(<*>) : Eff (a -> b) xs (\v => xs) -> Eff a xs (\v => xs) -> Eff b xs (\v => xs)-(<$>) prog v = do fn <- prog+(<*>) prog v = do fn <- prog arg <- v return (fn arg) @@ -309,5 +309,6 @@ when : Bool -> Lazy ({xs} Eff ()) -> {xs} Eff () when True e = Force e when False e = pure ()+ -- --------------------------------------------------------------------- [ EOF ]
libs/prelude/Builtins.idr view
@@ -19,6 +19,16 @@ ||| @b the right element of the pair MkPair : {A, B : Type} -> (a : A) -> (b : B) -> Pair A B + ||| The non-dependent pair type, also known as conjunction, usable with+ ||| 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+ ||| 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+ ||| Dependent pairs ||| ||| Dependent pairs represent existential quantification - they consist of a
libs/prelude/Decidable/Equality.idr view
@@ -181,15 +181,6 @@ primitiveEq = believe_me (Refl {x}) postulate primitiveNotEq : x = y -> Void ------------------------------------------------------------------------------------ Float-----------------------------------------------------------------------------------instance DecEq Float where- decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq- where primitiveEq : x = y- primitiveEq = believe_me (Refl {x})- postulate primitiveNotEq : x = y -> Void -------------------------------------------------------------------------------- -- String
libs/prelude/IO.idr view
@@ -11,17 +11,61 @@ prim__IO : a -> PrimIO a ||| A token representing the world, for use in `IO`-abstract data World = TheWorld+abstract data World = TheWorld prim__WorldType +private+world : World -> prim__WorldType+world (TheWorld w) = w+ abstract WorldRes : Type -> Type WorldRes x = x --- abstract data WorldRes a = MkWR a World+record FFI : Type where+ MkFFI : (ffi_types : Type -> Type) -> + (ffi_fn : Type) -> + (ffi_data : Type) -> FFI abstract -data IO : Type -> Type where- MkIO : (World -> PrimIO (WorldRes a)) -> IO a+data IO' : (lang : FFI) -> Type -> Type where+ MkIO : (World -> PrimIO (WorldRes a)) -> IO' lang a +data FTy : FFI -> List Type -> Type -> Type where+ FRet : ffi_types f t -> FTy f xs (IO' f t)+ FFun : ffi_types f s -> FTy f (s :: xs) t -> FTy f xs (s -> t)++namespace ForeignEnv+ data FEnv : FFI -> List Type -> Type where+ Nil : FEnv f []+ (::) : (ffi_types f t, t) -> FEnv f xs -> FEnv f (t :: xs)+ +ForeignPrimType : (xs : List Type) -> FEnv ffi xs -> Type -> Type+ForeignPrimType {ffi} [] [] t = World -> ffi_fn ffi -> ffi_types ffi t -> PrimIO t+ForeignPrimType {ffi} (x :: xs) ((a, _) :: env) t + = (ffi_types ffi x, x) -> ForeignPrimType xs env t++%inline+applyEnv : (env : FEnv ffi xs) -> + ForeignPrimType xs env t -> + World -> ffi_fn ffi -> ffi_types ffi t -> PrimIO t+applyEnv [] f = f+applyEnv (x@(_, _) :: xs) f = applyEnv xs (f x)++mkForeignPrim : ForeignPrimType xs env t+-- compiled as primitive++%inline+foreign_prim : (f : FFI) -> + (fname : ffi_fn f) -> FTy f xs ty -> FEnv f xs -> ty+foreign_prim f fname (FRet y) env+ = MkIO (\w => applyEnv env mkForeignPrim w fname y)+foreign_prim f fname (FFun arg sc) env+ = \x => foreign_prim f fname sc ((arg, x) :: env)++%inline+foreign : (f : FFI) -> (fname : ffi_fn f) -> (ty : Type) ->+ {auto fty : FTy f [] ty} -> ty+foreign ffi fname ty {fty} = foreign_prim ffi fname fty []+ abstract prim_io_bind : PrimIO a -> (a -> PrimIO b) -> PrimIO b prim_io_bind (prim__IO v) k = k v@@ -33,138 +77,174 @@ prim_io_return : a -> PrimIO a prim_io_return x = prim__IO x -||| Descriptions of the various sorts of Ints that Idris supports-data IntTy = ITChar | ITNative | IT8 | IT16 | IT32 | IT64 | IT8x16 | IT16x8 | IT32x4 | IT64x2+abstract+io_bind : IO' l a -> (a -> IO' l b) -> IO' l b+io_bind (MkIO fn) k+ = MkIO (\w => prim_io_bind (fn w)+ (\ b => case k b of+ MkIO fkb => fkb w)) -||| Types available for foreign function calls-data FTy = FIntT IntTy- | FFunction FTy FTy- | FFloat- | FString- | FPtr- | FManagedPtr- | FAny Type- | FUnit+abstract+io_return : a -> IO' l a+io_return x = MkIO (\w => prim_io_return x) -FInt : FTy-FInt = FIntT ITNative+liftPrimIO : (World -> PrimIO a) -> IO' l a+liftPrimIO = MkIO -FChar : FTy-FChar = FIntT ITChar+call__IO : IO' l a -> PrimIO a+call__IO (MkIO f) = f (TheWorld prim__TheWorld) -FByte : FTy-FByte = FIntT IT8+-- Concrete type makes it easier to elaborate at top level+run__IO : IO' l () -> PrimIO ()+run__IO f = call__IO f -FShort : FTy-FShort = FIntT IT16+unsafePerformIO : IO' ffi a -> a+unsafePerformIO (MkIO f) = unsafePerformPrimIO+ (prim_io_bind (f (TheWorld prim__TheWorld)) (\ b => prim_io_return b)) -FLong : FTy-FLong = FIntT IT64+prim_read : IO' l String+prim_read = MkIO (\w => prim_io_return (prim__readString (world w))) -FBits8 : FTy-FBits8 = FIntT IT8+prim_write : String -> IO' l Int+prim_write s + = MkIO (\w => prim_io_return (prim__writeString (world w) s)) -FBits16 : FTy-FBits16 = FIntT IT16+prim_fread : Ptr -> IO' l String+prim_fread h = MkIO (\w => prim_io_return (prim__readFile (world w) h)) -FBits32 : FTy-FBits32 = FIntT IT32+prim_fwrite : Ptr -> String -> IO' l Int+prim_fwrite h s + = MkIO (\w => prim_io_return (prim__writeFile (world w) h s)) -FBits64 : FTy-FBits64 = FIntT IT64+--------- The C FFI -FBits8x16 : FTy-FBits8x16 = FIntT IT8x16+data Raw : Type -> Type where+ -- code generated can assume it's compiled just as 't'+ MkRaw : (x : t) -> Raw t -FBits16x8 : FTy-FBits16x8 = FIntT IT16x8+-- Tell erasure analysis not to erase the argument+%used MkRaw x -FBits32x4 : FTy-FBits32x4 = FIntT IT32x4+-- 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 -FBits64x2 : FTy-FBits64x2 = FIntT IT64x2+-- 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 -||| Interpret an FFI type as the type of the Idris function that it will become-interpFTy : FTy -> Type-interpFTy (FIntT ITNative) = Int-interpFTy (FIntT ITChar) = Char-interpFTy (FIntT IT8) = Bits8-interpFTy (FIntT IT16) = Bits16-interpFTy (FIntT IT32) = Bits32-interpFTy (FIntT IT64) = Bits64-interpFTy (FAny t) = t-interpFTy FFloat = Float-interpFTy FString = String-interpFTy FPtr = Ptr-interpFTy FManagedPtr = ManagedPtr-interpFTy (FIntT IT8x16) = Bits8x16-interpFTy (FIntT IT16x8) = Bits16x8-interpFTy (FIntT IT32x4) = Bits32x4-interpFTy (FIntT IT64x2) = Bits64x2-interpFTy FUnit = ()+FFI_C : FFI +FFI_C = MkFFI C_Types String String -interpFTy (FFunction a b) = interpFTy a -> interpFTy b+IO : Type -> Type+IO = IO' FFI_C -||| Type signatures for foreign functions-||| @ xs the argument types-||| @ t the return type-ForeignTy : (xs : List FTy) -> (t : FTy) -> Type-ForeignTy Nil rt = World -> PrimIO (interpFTy rt)-ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt+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 -data Foreign : Type -> Type where- FFun : String -> (xs:List FTy) -> (t:FTy) ->- Foreign (ForeignTy xs t)+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)) -mkForeignPrim : Foreign x -> x-mkLazyForeignPrim : Foreign x -> x--- mkForeign and mkLazyForeign compiled as primitives+forceGC : IO ()+forceGC = foreign FFI_C "idris_forceGC" (Ptr -> IO ()) prim__vm -registerPtr : Ptr -> Int -> ManagedPtr-registerPtr = prim__registerPtr+--------- The Javascript/Node FFI -abstract-io_bind : IO a -> (a -> IO b) -> IO b-io_bind (MkIO fn) k- = MkIO (\w => prim_io_bind (fn w)- (\ b => case k b of- MkIO fkb => fkb w)) -abstract-io_return : a -> IO a-io_return x = MkIO (\w => prim_io_return x)+-- Supported JS foreign types+mutual+ data JsFn : Type -> Type where+ MkJsFn : (x : t) -> JsFn t -liftPrimIO : (World -> PrimIO a) -> IO a-liftPrimIO = MkIO+ data JS_IntTypes : Type -> Type where+ JS_IntChar : JS_IntTypes Char+ JS_IntNative : JS_IntTypes Int -run__IO : IO () -> PrimIO ()-run__IO (MkIO f) = f TheWorld+ data JS_FnTypes : Type -> Type where+ JS_Fn : JS_Types s -> JS_FnTypes t -> JS_FnTypes (s -> t)+ JS_FnIO : JS_Types t -> JS_FnTypes (IO' l t)+ JS_FnBase : JS_Types t -> JS_FnTypes t -run__provider : IO a -> PrimIO a-run__provider (MkIO f) = f TheWorld+ data JS_Types : Type -> Type where+ JS_Str : JS_Types String+ JS_Float : JS_Types Float+ JS_Ptr : JS_Types Ptr+ JS_Unit : JS_Types ()+ JS_FnT : JS_FnTypes a -> JS_Types (JsFn a)+ JS_IntT : JS_IntTypes i -> JS_Types i --- io_bind v (\v' => io_return v')+-- Tell erasure analysis not to erase the argument. Needs to be outside the+-- mutual block, since directives are done on the first pass and in the first+-- pass we only have 'JsFn' and not the constructor.+%used MkJsFn x -prim_fork : PrimIO () -> PrimIO Ptr-prim_fork x = prim_io_return prim__vm -- compiled specially+FFI_JS : FFI +FFI_JS = MkFFI JS_Types String String -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))+JS_IO : Type -> Type+JS_IO = IO' FFI_JS -partial-prim_fread : Ptr -> IO String-prim_fread h = MkIO (\w => prim_io_return (prim__readString h)) -unsafePerformIO : IO a -> a-unsafePerformIO (MkIO f) = unsafePerformPrimIO- (prim_io_bind (f TheWorld) (\ b => prim_io_return b))+--------- Foreign Exports +namespace FFI_Export+-- It's just like Data.List.Elem, but we don't need all the other stuff+-- that comes with it, just a proof that a data type is defined.+ data DataDefined : Type -> List (Type, s) -> s -> Type where+ DHere : DataDefined x ((x, t) :: xs) t+ DThere : DataDefined x xs t -> DataDefined x (y :: xs) t -forceGC : IO ()-forceGC = mkForeign (FFun "idris_forceGC" [FPtr] FUnit) prim__vm+ data FFI_Base : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where+ FFI_ExpType : {n : ffi_data f} -> (def : DataDefined t xs n) -> FFI_Base f xs t+ FFI_Prim : (prim : ffi_types f t) -> FFI_Base f xs t++ %used FFI_ExpType n+ %used FFI_ExpType def+ %used FFI_Prim prim++ data FFI_Exportable : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where+ FFI_IO : (b : FFI_Base f xs t) -> FFI_Exportable f xs (IO t)+ FFI_Fun : (b : FFI_Base f xs s) -> (a : FFI_Exportable f xs t) -> FFI_Exportable f xs (s -> t)+ FFI_Ret : (b : FFI_Base f xs t) -> FFI_Exportable f xs t++ %used FFI_IO b+ %used FFI_Fun b+ %used FFI_Fun a+ %used FFI_Ret b++ data FFI_Export : (f : FFI) -> String -> List (Type, ffi_data f) -> Type where+ Data : (x : Type) -> (n : ffi_data f) -> + (es : FFI_Export f h ((x, n) :: xs)) -> FFI_Export f h xs+ Fun : (fn : t) -> (n : ffi_fn f) -> {auto prf : FFI_Exportable f xs t} -> + (es : FFI_Export f h xs) -> FFI_Export f h xs+ End : FFI_Export f h xs++%used Data x+%used Data n+%used Data es+%used Fun fn+%used Fun n+%used Fun es+%used Fun prf
libs/prelude/Language/Reflection.idr view
@@ -49,7 +49,7 @@ | B32V Bits32x4 | B64V Bits64x2 | AType ArithTy | StrType | PtrType | ManagedPtrType | BufferType | VoidType | Forgot-+ | WorldType | TheWorld %name Const c, c' abstract class ReflConst (a : Type) where@@ -146,6 +146,8 @@ traverse f (PVar x) = [| PVar (f x) |] traverse f (PVTy x) = [| PVTy (f x) |] +||| Universes+data Universe = NullType | UniqueType | AllTypes ||| Reflection of the well typed core language data TT =@@ -166,7 +168,8 @@ ||| Impossible terms Impossible | ||| The type of types along (with universe constraints)- TType TTUExp+ TType TTUExp |+ UType Universe %name TT tm, tm' ||| Raw terms without types@@ -179,6 +182,7 @@ RApp Raw Raw | ||| The type of types RType |+ RUType Universe | RForce Raw | ||| Embed a constant RConstant Const@@ -213,6 +217,10 @@ Refine TTName | ||| Apply both tactics in sequence Seq Tactic Tactic |+ ||| Introduce a new hole with a particular type+ Claim TTName TT |+ ||| Move the current hole to the end+ Unfocus | ||| Intelligently construct the proof target from the context Trivial | ||| Build a proof by applying contructors up to a maximum depth@@ -259,108 +267,193 @@ %name Tactic tac, tac' -||| Things with a canonical representation in the TT datatype.+||| Things with a canonical representation as a reflected term. ||| ||| This type class is intended to be used during proof automation and the ||| construction of custom tactics. ||| ||| @ a the type to be quoted-class Quotable a where+||| @ t the type to quote it to (typically `TT` or `Raw`)+class Quotable a t where ||| A representation of the type `a`. ||| ||| This is to enable quoting polymorphic datatypes- quotedTy : TT+ quotedTy : t ||| Quote a particular element of `a`. ||| ||| Each equation should look something like ```quote (Foo x y) = `(Foo ~(quote x) ~(quote y))```- quote : a -> TT+ quote : a -> t -instance Quotable Nat where+instance Quotable Nat TT where quotedTy = `(Nat) quote Z = `(Z) quote (S k) = `(S ~(quote k)) -instance Quotable Int where+instance Quotable Nat Raw where+ quotedTy = `(Nat)++ quote Z = `(Z)+ quote (S k) = `(S ~(quote k))++instance Quotable Int TT where quotedTy = `(Int) quote x = TConst (I x) -instance Quotable Float where+instance Quotable Int Raw where+ quotedTy = `(Int)+ quote x = RConstant (I x)++instance Quotable Float TT where quotedTy = `(Float) quote x = TConst (Fl x) -instance Quotable Char where+instance Quotable Float Raw where+ quotedTy = `(Float)+ quote x = RConstant (Fl x)++instance Quotable Char TT where quotedTy = `(Char) quote x = TConst (Ch x) -instance Quotable Bits8 where+instance Quotable Char Raw where+ quotedTy = `(Char)+ quote x = RConstant (Ch x)++instance Quotable Bits8 TT where quotedTy = `(Bits8) quote x = TConst (B8 x) -instance Quotable Bits16 where+instance Quotable Bits8 Raw where+ quotedTy = `(Bits8)+ quote x = RConstant (B8 x)++instance Quotable Bits16 TT where quotedTy = `(Bits16) quote x = TConst (B16 x) -instance Quotable Bits32 where+instance Quotable Bits16 Raw where+ quotedTy = `(Bits16)+ quote x = RConstant (B16 x)++instance Quotable Bits32 TT where quotedTy = `(Bits32) quote x = TConst (B32 x) -instance Quotable Bits64 where+instance Quotable Bits32 Raw where+ quotedTy = `(Bits32)+ quote x = RConstant (B32 x)++instance Quotable Bits64 TT where quotedTy = `(Bits64) quote x = TConst (B64 x) -instance Quotable Integer where+instance Quotable Bits64 Raw where+ quotedTy = `(Bits64)+ quote x = RConstant (B64 x)++instance Quotable Integer TT where quotedTy = `(Integer) quote x = TConst (BI x) -instance Quotable Bits8x16 where+instance Quotable Integer Raw where+ quotedTy = `(Integer)+ quote x = RConstant (BI x)++instance Quotable Bits8x16 TT where quotedTy = `(Bits8x16) quote x = TConst (B8V x) -instance Quotable Bits16x8 where+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 Bits32x4 where+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 Bits64x2 where+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 String where+instance Quotable Bits64x2 Raw where+ quotedTy = `(Bits64x2)+ quote x = RConstant (B64V x)++instance Quotable String TT where quotedTy = `(String) quote x = TConst (Str x) -instance Quotable NameType where+instance Quotable String Raw where+ quotedTy = `(String)+ quote x = RConstant (Str x)++instance Quotable NameType TT where quotedTy = `(NameType) quote Bound = `(Bound) quote Ref = `(Ref) quote (DCon x y) = `(DCon ~(quote x) ~(quote y)) quote (TCon x y) = `(TCon ~(quote x) ~(quote y)) -instance Quotable a => Quotable (List a) where- quotedTy = `(List ~(quotedTy {a=a}))- quote [] = `(List.Nil {a=~quotedTy})- quote (x :: xs) = `(List.(::) {a=~quotedTy} ~(quote x) ~(quote xs))+instance Quotable NameType Raw where+ quotedTy = `(NameType)+ quote Bound = `(Bound)+ quote Ref = `(Ref)+ quote (DCon x y) = `(DCon ~(quote {t=Raw} x) ~(quote {t=Raw} y))+ quote (TCon x y) = `(TCon ~(quote {t=Raw} x) ~(quote {t=Raw} y)) -instance Quotable TTName where+instance Quotable a TT => Quotable (List a) TT where+ quotedTy = `(List ~(quotedTy {a}))+ quote [] = `(List.Nil {a=~(quotedTy {a})})+ quote (x :: xs) = `(List.(::) {a=~(quotedTy {a})} ~(quote x) ~(quote xs))++instance Quotable a Raw => Quotable (List a) Raw where+ quotedTy = `(List ~(quotedTy {a}))+ 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) -instance Quotable NativeTy where+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 NativeTy TT where quotedTy = `(NativeTy) quote IT8 = `(Reflection.IT8) quote IT16 = `(Reflection.IT16) quote IT32 = `(Reflection.IT32) quote IT64 = `(Reflection.IT64) -instance Quotable Reflection.IntTy where+instance Quotable NativeTy Raw where+ quotedTy = `(NativeTy)+ quote IT8 = `(Reflection.IT8)+ quote IT16 = `(Reflection.IT16)+ quote IT32 = `(Reflection.IT32)+ quote IT64 = `(Reflection.IT64)++instance Quotable Reflection.IntTy TT where quotedTy = `(Reflection.IntTy) quote (ITFixed x) = `(ITFixed ~(quote x)) quote ITNative = `(Reflection.ITNative)@@ -368,12 +461,25 @@ quote ITChar = `(Reflection.ITChar) quote (ITVec x y) = `(ITVec ~(quote x) ~(quote y)) -instance Quotable ArithTy where+instance Quotable Reflection.IntTy Raw where+ quotedTy = `(Reflection.IntTy)+ quote (ITFixed x) = `(ITFixed ~(quote {t=Raw} x))+ 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) quote (ATInt x) = `(ATInt ~(quote x)) quote ATFloat = `(ATFloat) -instance Quotable Const where+instance Quotable ArithTy Raw where+ quotedTy = `(ArithTy)+ quote (ATInt x) = `(ATInt ~(quote {t=Raw} x))+ quote ATFloat = `(ATFloat)++instance Quotable Const TT where quotedTy = `(Const) quote (I x) = `(I ~(quote x)) quote (BI x) = `(BI ~(quote x))@@ -395,15 +501,58 @@ quote BufferType = `(BufferType) quote VoidType = `(VoidType) quote Forgot = `(Forgot)+ quote WorldType = `(WorldType)+ quote TheWorld = `(TheWorld) +instance Quotable Const Raw where+ quotedTy = `(Const)+ quote (I x) = `(I ~(quote {t=Raw} x))+ quote (BI x) = `(BI ~(quote {t=Raw} x))+ quote (Fl x) = `(Fl ~(quote {t=Raw} x))+ quote (Ch x) = `(Ch ~(quote {t=Raw} x))+ quote (Str x) = `(Str ~(quote {t=Raw} x))+ quote (B8 x) = `(B8 ~(quote {t=Raw} x))+ 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)+ quote TheWorld = `(TheWorld) -instance Quotable TTUExp where+instance Quotable TTUExp TT where quotedTy = `(TTUExp) quote (UVar x) = `(UVar ~(quote x)) quote (UVal x) = `(UVal ~(quote x)) +instance Quotable TTUExp Raw where+ quotedTy = `(TTUExp)+ quote (UVar x) = `(UVar ~(quote {t=Raw} x))+ quote (UVal x) = `(UVal ~(quote {t=Raw} x))++instance Quotable Universe TT where+ quotedTy = `(Universe)+ quote Reflection.NullType = `(NullType)+ quote Reflection.UniqueType = `(UniqueType)+ quote Reflection.AllTypes = `(AllTypes)++instance Quotable Universe Raw where+ quotedTy = `(Universe)+ quote Reflection.NullType = `(NullType)+ quote Reflection.UniqueType = `(UniqueType)+ quote Reflection.AllTypes = `(AllTypes)+ mutual- instance Quotable TT where+ instance Quotable TT TT where quotedTy = `(TT) quote (P nt n tm) = `(P ~(quote nt) ~(quote n) ~(quote tm)) quote (V x) = `(V ~(quote x))@@ -414,8 +563,9 @@ quote Erased = `(Erased) quote Impossible = `(Impossible) quote (TType uexp) = `(TType ~(quote uexp))+ quote (UType u) = `(UType ~(quote u)) - instance Quotable (Binder TT) where+ instance Quotable (Binder TT) TT where quotedTy = `(Binder TT) quote (Lam x) = `(Lam {a=TT} ~(assert_total (quote x))) quote (Pi x k) = `(Pi {a=TT} ~(assert_total (quote x))@@ -432,7 +582,7 @@ quote (PVTy x) = `(PVTy {a=TT} ~(assert_total (quote x))) -instance Quotable ErrorReportPart where+instance Quotable ErrorReportPart TT where quotedTy = `(ErrorReportPart) quote (TextPart x) = `(TextPart ~(quote x)) quote (NamePart n) = `(NamePart ~(quote n))@@ -445,6 +595,7 @@ quoteRaw (RBind n b tm) = `(RBind ~(quote n) ~(assert_total $ quoteRawBinder b) ~(quoteRaw tm)) quoteRaw (RApp tm tm') = `(RApp ~(quoteRaw tm) ~(quoteRaw tm')) quoteRaw RType = `(RType)+ quoteRaw (RUType u) = `(RUType ~(quote u)) quoteRaw (RForce tm) = `(RForce ~(quoteRaw tm)) quoteRaw (RConstant c) = `(RConstant ~(quote c)) @@ -459,19 +610,21 @@ quoteRawBinder (PVar x) = `(PVar {a=Raw} ~(quoteRaw x)) quoteRawBinder (PVTy x) = `(PVTy {a=Raw} ~(quoteRaw x)) -instance Quotable Raw where+instance Quotable Raw TT where quotedTy = `(Raw) quote = quoteRaw -instance Quotable (Binder Raw) where+instance Quotable (Binder Raw) TT where quotedTy = `(Binder Raw) quote = quoteRawBinder -instance Quotable Tactic where+instance Quotable Tactic TT where quotedTy = `(Tactic) quote (Try tac tac') = `(Try ~(quote tac) ~(quote tac')) quote (GoalType x tac) = `(GoalType ~(quote x) ~(quote tac)) quote (Refine n) = `(Refine ~(quote n))+ quote (Claim n ty) = `(Claim ~(quote n) ~(quote ty))+ quote Unfocus = `(Unfocus) quote (Seq tac tac') = `(Seq ~(quote tac) ~(quote tac')) quote Trivial = `(Trivial) quote (Search x) = `(Search ~(quote x))@@ -494,3 +647,18 @@ quote Skip = `(Skip) quote (Fail xs) = `(Fail ~(quote xs)) quote SourceFC = `(SourceFC)+++instance Quotable SourceLocation TT where+ quotedTy = `(SourceLocation)+ quote (FileLoc fn (sl, sc) (el, ec)) =+ `(FileLoc ~(quote fn)+ (~(quote sl), ~(quote sc))+ (~(quote el), ~(quote ec)))++instance Quotable SourceLocation Raw where+ quotedTy = `(SourceLocation)+ quote (FileLoc fn (sl, sc) (el, ec)) =+ `(FileLoc ~(quote {t=Raw} fn)+ (~(quote {t=Raw} sl), ~(quote {t=Raw} sc))+ (~(quote {t=Raw} el), ~(quote {t=Raw} ec)))
libs/prelude/Language/Reflection/Errors.idr view
@@ -29,8 +29,10 @@ | NoTypeDecl TTName | NotInjective TT TT TT | CantResolve TT- | CantResolveAlts (List String)+ | InvalidTCArg TTName TT+ | CantResolveAlts (List TTName) | IncompleteTerm TT+ | NoEliminator String TT | UniverseError | ProgramLineComment | Inaccessible TTName
+ libs/prelude/Language/Reflection/Tactical.idr view
@@ -0,0 +1,138 @@+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
@@ -23,7 +23,7 @@ import public Prelude.Uninhabited import public Prelude.Pairs import public Prelude.Stream-+import public Prelude.Providers import public Decidable.Equality import public Language.Reflection import public Language.Reflection.Errors@@ -233,7 +233,7 @@ instance Functor PrimIO where map f io = prim_io_bind io (prim_io_return . f) -instance Functor IO where+instance Functor (IO' ffi) where map f io = io_bind io (\b => io_return (f b)) instance Functor Maybe where@@ -249,31 +249,31 @@ instance Applicative PrimIO where pure = prim_io_return - am <$> bm = prim_io_bind am (\f => prim_io_bind bm (prim_io_return . f))+ am <*> bm = prim_io_bind am (\f => prim_io_bind bm (prim_io_return . f)) -instance Applicative IO where+instance Applicative (IO' ffi) where pure x = io_return x- f <$> a = io_bind f (\f' =>+ f <*> a = io_bind f (\f' => io_bind a (\a' => io_return (f' a'))) instance Applicative Maybe where pure = Just - (Just f) <$> (Just a) = Just (f a)- _ <$> _ = Nothing+ (Just f) <*> (Just a) = Just (f a)+ _ <*> _ = Nothing instance Applicative (Either e) where pure = Right - (Left a) <$> _ = Left a- (Right f) <$> (Right r) = Right (f r)- (Right _) <$> (Left l) = Left l+ (Left a) <*> _ = Left a+ (Right f) <*> (Right r) = Right (f r)+ (Right _) <*> (Left l) = Left l instance Applicative List where pure x = [x] - fs <$> vs = concatMap (\f => map f vs) fs+ fs <*> vs = concatMap (\f => map f vs) fs ---- Alternative instances @@ -293,7 +293,7 @@ instance Monad PrimIO where b >>= k = prim_io_bind b k -instance Monad IO where+instance Monad (IO' ffi) where b >>= k = io_bind b k instance Monad Maybe where@@ -434,34 +434,43 @@ ---- some basic io ||| Output a string to stdout without a trailing newline-partial-putStr : String -> IO ()-putStr x = mkForeign (FFun "putStr" [FString] FUnit) x+putStr : String -> IO' ffi ()+putStr x = do prim_write x+ return () ||| Output a string to stdout with a trailing newline-partial-putStrLn : String -> IO ()+putStrLn : String -> IO' ffi () putStrLn x = putStr (x ++ "\n") +||| Output something showable to stdout, without a trailing newline+partial+print : Show a => a -> IO' ffi ()+print x = putStr (show x)+ ||| Output something showable to stdout, with a trailing newline partial-print : Show a => a -> IO ()-print x = putStrLn (show x)+printLn : Show a => a -> IO' ffi ()+printLn x = putStrLn (show x) ||| Read one line of input from stdin partial-getLine : IO String-getLine = prim_fread prim__stdin+getLine : IO' ffi String+getLine = prim_read ||| Write a single character to stdout partial putChar : Char -> IO ()-putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c)+putChar c = foreign FFI_C "putchar" (Int -> IO ()) (cast c) +||| Write a singel character to stdout, with a trailing newline+partial+putCharLn : Char -> IO ()+putCharLn c = putStrLn (singleton c)+ ||| Read a single character from stdin partial getChar : IO Char-getChar = map cast $ mkForeign (FFun "getchar" [] FInt)+getChar = map cast $ foreign FFI_C "getchar" (IO Int) ---- some basic file handling @@ -470,21 +479,21 @@ data File = FHandle Ptr ||| Standard input-partial stdin : File+stdin : File stdin = FHandle prim__stdin ||| Standard output-partial stdout : File+stdout : File stdout = FHandle prim__stdout ||| Standard output-partial stderr : File+stderr : File stderr = FHandle prim__stderr ||| Call the RTS's file opening function do_fopen : String -> String -> IO Ptr do_fopen f m- = mkForeign (FFun "fileOpen" [FString, FString] FPtr) f m+ = foreign FFI_C "fileOpen" (String -> String -> IO Ptr) f m ||| Open a file ||| @ f the filename@@ -508,30 +517,30 @@ partial do_fclose : Ptr -> IO ()-do_fclose h = mkForeign (FFun "fileClose" [FPtr] FUnit) h+do_fclose h = foreign FFI_C "fileClose" (Ptr -> IO ()) h partial closeFile : File -> IO () closeFile (FHandle h) = do_fclose h partial-do_fread : Ptr -> IO String+do_fread : Ptr -> IO' l String do_fread h = prim_fread h fgetc : File -> IO Char-fgetc (FHandle h) = return (cast !(mkForeign (FFun "fgetc" [FPtr] FInt) h))+fgetc (FHandle h) = return (cast !(foreign FFI_C "fgetc" (Ptr -> IO Int) h)) fgetc' : File -> IO (Maybe Char) fgetc' (FHandle h)- = do x <- mkForeign (FFun "fgetc" [FPtr] FInt) h+ = do x <- foreign FFI_C "fgetc" (Ptr -> IO Int) h if (x < 0) then return Nothing else return (Just (cast x)) fflush : File -> IO ()-fflush (FHandle h) = mkForeign (FFun "fflush" [FPtr] FUnit) h+fflush (FHandle h) = foreign FFI_C "fflush" (Ptr -> IO ()) h do_popen : String -> String -> IO Ptr-do_popen f m = mkForeign (FFun "do_popen" [FString, FString] FPtr) f m+do_popen f m = foreign FFI_C "do_popen" (String -> String -> IO Ptr) f m popen : String -> Mode -> IO File popen f m = do ptr <- do_popen f (modeStr m)@@ -542,19 +551,19 @@ modeStr ReadWrite = "r+" pclose : File -> IO ()-pclose (FHandle h) = mkForeign (FFun "pclose" [FPtr] FUnit) h+pclose (FHandle h) = foreign FFI_C "pclose" (Ptr -> IO ()) h -- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String)) -- prim__vm h partial-fread : File -> IO String+fread : File -> IO' l String fread (FHandle h) = do_fread h partial do_fwrite : Ptr -> String -> IO ()-do_fwrite h s- = mkForeign (FFun "fputStr" [FPtr, FString] FUnit) h s+do_fwrite h s = do prim_fwrite h s+ return () partial fwrite : File -> String -> IO ()@@ -562,7 +571,7 @@ partial do_feof : Ptr -> IO Int-do_feof h = mkForeign (FFun "fileEOF" [FPtr] FInt) h+do_feof h = foreign FFI_C "fileEOF" (Ptr -> IO Int) h ||| Check if a file handle has reached the end feof : File -> IO Bool@@ -571,31 +580,45 @@ partial do_ferror : Ptr -> IO Int-do_ferror h = mkForeign (FFun "fileError" [FPtr] FInt) h+do_ferror h = foreign FFI_C "fileError" (Ptr -> IO Int) h ferror : File -> IO Bool ferror (FHandle h) = do err <- do_ferror h return (not (err == 0)) fpoll : File -> IO Bool-fpoll (FHandle h) = do p <- mkForeign (FFun "fpoll" [FPtr] FInt) h+fpoll (FHandle h) = do p <- foreign FFI_C "fpoll" (Ptr -> IO Int) h return (p > 0) ||| Check if a foreign pointer is null partial nullPtr : Ptr -> IO Bool-nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p+nullPtr p = do ok <- foreign FFI_C "isNull" (Ptr -> IO Int) p return (ok /= 0) ||| Check if a supposed string was actually a null pointer partial nullStr : String -> IO Bool-nullStr p = do ok <- mkForeign (FFun "isNull" [FString] FInt) p+nullStr p = do ok <- foreign FFI_C "isNull" (String -> IO Int) p return (ok /= 0) +namespace JSNull+ ||| Check if a foreign pointer is null+ partial+ nullPtr : Ptr -> JS_IO Bool+ nullPtr p = do ok <- foreign FFI_JS "isNull" (Ptr -> JS_IO Int) p+ return (ok /= 0)++ ||| Check if a supposed string was actually a null pointer+ partial+ nullStr : String -> JS_IO Bool+ nullStr p = do ok <- foreign FFI_JS "isNull" (String -> JS_IO Int) p+ return (ok /= 0)++ ||| Pointer equality eqPtr : Ptr -> Ptr -> IO Bool-eqPtr x y = do eq <- mkForeign (FFun "idris_eqPtr" [FPtr, FPtr] FInt) x y+eqPtr x y = do eq <- foreign FFI_C "idris_eqPtr" (Ptr -> Ptr -> IO Int) x y return (eq /= 0) ||| Check whether a file handle is actually a null pointer
libs/prelude/Prelude/Algebra.idr view
@@ -5,7 +5,7 @@ -- XXX: change? infixl 6 <-> infixl 6 <+>-infixl 6 <*>+infixl 6 <.> infixl 5 <#> %access public@@ -22,8 +22,6 @@ class Semigroup a where (<+>) : a -> a -> a -class Semigroup a => VerifiedSemigroup a where- total semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r ||| Sets equipped with a single binary operation that is associative, along with ||| a neutral element for that binary operation. Must satisfy the following@@ -37,295 +35,3 @@ class Semigroup a => Monoid a where neutral : a -class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where- total monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l- total monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r--||| 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:-||| + Associativity of `<+>`:-||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c-||| + Neutral for `<+>`:-||| forall a, a <+> neutral == a-||| forall a, neutral <+> a == a-||| + Inverse for `<+>`:-||| forall a, a <+> inverse a == neutral-||| forall a, inverse a <+> a == neutral-class Monoid a => Group a where- inverse : a -> a--class (VerifiedMonoid a, Group a) => VerifiedGroup a where- total groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral- total groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral--(<->) : Group a => a -> a -> a-(<->) left right = left <+> (inverse right)--||| Sets equipped with a single binary operation that is associative and-||| commutative, along with a neutral element for that binary operation and-||| inverses for all elements. Must satisfy the following laws:-|||-||| + Associativity of `<+>`:-||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c-||| + Commutativity of `<+>`:-||| forall a b, a <+> b == b <+> a-||| + Neutral for `<+>`:-||| forall a, a <+> neutral == a-||| forall a, neutral <+> a == a-||| + Inverse for `<+>`:-||| forall a, a <+> inverse a == neutral-||| forall a, inverse a <+> a == neutral-class Group a => AbelianGroup a where { }--class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where- total abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l--||| 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-||| laws:-|||-||| + Associativity of `<+>`:-||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c-||| + Commutativity of `<+>`:-||| forall a b, a <+> b == b <+> a-||| + Neutral for `<+>`:-||| forall a, a <+> neutral == a-||| forall a, neutral <+> a == a-||| + Inverse for `<+>`:-||| forall a, a <+> inverse a == neutral-||| forall a, inverse a <+> a == neutral-||| + Associativity of `<*>`:-||| forall a b c, a <*> (b <*> c) == (a <*> b) <*> c-||| + 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 AbelianGroup a => Ring a where- (<*>) : a -> a -> a--class (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where- total ringOpIsAssociative : (l, c, r : a) -> l <*> (c <*> r) = (l <*> c) <*> r- total ringOpIsDistributiveL : (l, c, r : a) -> l <*> (c <+> r) = (l <*> c) <+> (l <*> r)- total ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <*> r = (l <*> r) <+> (c <*> r)--||| 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-||| satisfy the following laws:-|||-||| + Associativity of `<+>`:-||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c-||| + Commutativity of `<+>`:-||| forall a b, a <+> b == b <+> a-||| + Neutral for `<+>`:-||| forall a, a <+> neutral == a-||| forall a, neutral <+> a == a-||| + Inverse for `<+>`:-||| forall a, a <+> inverse a == neutral-||| forall a, inverse a <+> a == neutral-||| + Associativity of `<*>`:-||| forall a b c, a <*> (b <*> c) == (a <*> b) <*> c-||| + Neutral for `<*>`:-||| forall a, a <*> unity == a-||| forall a, unity <*> a == a-||| + 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 Ring a => RingWithUnity a where- unity : a--class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where- total ringWithUnityIsUnityL : (l : a) -> l <*> unity = l- total ringWithUnityIsUnityR : (r : a) -> unity <*> r = r--||| 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--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- total joinSemilatticeJoinIsIdempotent : (e : a) -> join e e = e--||| 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--class MeetSemilattice a => VerifiedMeetSemilattice a where- total meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r- total meetSemilatticeMeetIsCommutative : (l, r : a) -> meet l r = meet r l- total meetSemilatticeMeetIsIdempotent : (e : a) -> meet e e = e--||| 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--class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where- total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = e--||| 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--class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where- total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = e--||| 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 { }--class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where- total latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l- total latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l--||| 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 { }--class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }---- Fields.-||| Sets equipped with two binary operations, both associative and commutative-||| supplied with a neutral element, with-||| distributivity laws relating the two operations. Must satisfy the following-||| laws:-|||-||| + Associativity of `<+>`:-||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c-||| + Commutativity of `<+>`:-||| forall a b, a <+> b == b <+> a-||| + Neutral for `<+>`:-||| forall a, a <+> neutral == a-||| forall a, neutral <+> a == a-||| + Inverse for `<+>`:-||| forall a, a <+> inverse a == neutral-||| forall a, inverse a <+> a == neutral-||| + Associativity of `<*>`:-||| forall a b c, a <*> (b <*> c) == (a <*> b) <*> c-||| + Unity for `<*>`:-||| forall a, a <*> unity == a-||| forall a, unity <*> a == a-||| + InverseM of `<*>`:-||| forall a, a <*> inverseM a == unity-||| forall a, inverseM a <*> a == unity-||| + Distributivity of `<*>` and `<->`:-||| forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)-||| forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)-class RingWithUnity a => Field a where- inverseM : a -> a--class (VerifiedRing a, Field a) => VerifiedField a where- total fieldInverseIsInverseL : (l : a) -> l <*> inverseM l = unity- total fieldInverseIsInverseR : (r : a) -> inverseM r <*> r = unity--||| 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--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)--||| A vector space is a module over a ring that is also a field-class (Field a, Module a b) => VectorSpace a b where {}--class (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}---- XXX todo:--- Structures where "abs" make sense.--- Euclidean domains, etc.--- Where to put fromInteger and fromRational?
libs/prelude/Prelude/Applicative.idr view
@@ -9,46 +9,31 @@ ---- Applicative functors/Idioms -infixl 2 <$>+infixl 2 <*> class Functor f => Applicative (f : Type -> Type) where pure : a -> f a- (<$>) : f (a -> b) -> f a -> f b--instance Applicative id where- pure a = a- f <$> a = f a--class (Applicative f, VerifiedFunctor f) => VerifiedApplicative (f : Type -> Type) where- applicativeMap : (x : f a) -> (g : a -> b) ->- map g x = pure g <$> x- applicativeIdentity : (x : f a) -> pure id <$> x = x- applicativeComposition : (x : f a) -> (g1 : f (a -> b)) -> (g2 : f (b -> c)) ->- ((pure (.) <$> g2) <$> g1) <$> x = g2 <$> (g1 <$> x)- applicativeHomomorphism : (x : a) -> (g : a -> b) ->- (<$>) {f} (pure g) (pure x) = pure {f} (g x)- applicativeInterchange : (x : a) -> (g : f (a -> b)) ->- g <$> pure x = pure (\g' : a -> b => g' x) <$> g+ (<*>) : f (a -> b) -> f a -> f b -infixl 2 <$-(<$) : Applicative f => f a -> f b -> f a-a <$ b = map const a <$> b+infixl 2 <*+(<*) : Applicative f => f a -> f b -> f a+a <* b = map const a <*> b -infixl 2 $>-($>) : Applicative f => f a -> f b -> f b-a $> b = map (const id) a <$> b+infixl 2 *>+(*>) : Applicative f => f a -> f b -> f b+a *> b = map (const id) a <*> b ||| Lift a function to an applicative liftA : Applicative f => (a -> b) -> f a -> f b-liftA f a = pure f <$> a+liftA f a = pure f <*> a ||| Lift a two-argument function to an applicative liftA2 : Applicative f => (a -> b -> c) -> f a -> f b -> f c-liftA2 f a b = (map f a) <$> b+liftA2 f a b = (map f a) <*> b ||| Lift a three-argument function to an applicative liftA3 : Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d-liftA3 f a b c = (map f a) <$> b <$> c+liftA3 f a b c = (map f a) <*> b <*> c infixl 3 <|> class Applicative f => Alternative (f : Type -> Type) where
libs/prelude/Prelude/Basics.idr view
@@ -31,7 +31,7 @@ ||| Function composition (.) : (b -> c) -> (a -> b) -> a -> c-(.) f g x = f (g x)+(.) f g = \x => f (g x) ||| Takes in the first two arguments in reverse order. ||| @ f the function to flip
libs/prelude/Prelude/Foldable.idr view
@@ -11,7 +11,7 @@ class Foldable (t : Type -> Type) where foldr : (elt -> acc -> acc) -> acc -> t elt -> acc- foldl : Foldable t => (acc -> elt -> acc) -> acc -> t elt -> acc+ foldl : (acc -> elt -> acc) -> acc -> t elt -> acc foldl f z t = foldr (flip (.) . flip f) id t z ||| Combine each element of a structure into a monoid
libs/prelude/Prelude/Functor.idr view
@@ -10,11 +10,11 @@ ||| @ m the morphism map : (m : a -> b) -> f a -> f b -class Functor f => VerifiedFunctor (f : Type -> Type) where- functorIdentity : {a : Type} -> (x : f a) -> map id x = id x- functorComposition : {a : Type} -> {b : Type} -> (x : f a) ->- (g1 : a -> b) -> (g2 : b -> c) ->- map (g2 . g1) x = (map g2 . map g1) x+infixl 4 <$> -instance Functor id where- map f a = f a+||| An infix alias for `map`: the action of a functor on morphisms.+||| @ f the functor+||| @ m the morphism+(<$>) : Functor f => (m : a -> b) -> f a -> f b+m <$> x = map m x+
libs/prelude/Prelude/List.idr view
@@ -809,12 +809,6 @@ hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False hasAnyNilFalse l = ?hasAnyNilFalseBody -instance VerifiedSemigroup (List a) where- semigroupOpIsAssociative = appendAssociative--instance VerifiedMonoid (List a) where- monoidNeutralIsNeutralL = appendNilRightNeutral- monoidNeutralIsNeutralR xs = Refl -------------------------------------------------------------------------------- -- Proofs
libs/prelude/Prelude/Monad.idr view
@@ -14,19 +14,6 @@ class Applicative m => Monad (m : Type -> Type) where (>>=) : m a -> (a -> m b) -> m b -class (Monad m, VerifiedApplicative m) => VerifiedMonad (m : Type -> Type) where- monadApplicative : (mf : m (a -> b)) -> (mx : m a) ->- mf <$> mx = mf >>= \f =>- mx >>= \x =>- pure (f x)- monadLeftIdentity : (x : a) -> (f : a -> m b) -> return x >>= f = f x- monadRightIdentity : (mx : m a) -> mx >>= return = mx- monadAssociativity : (mx : m a) -> (f : a -> m b) -> (g : b -> m c) ->- (mx >>= f) >>= g = mx >>= (\x => f x >>= g)--instance Monad id where- a >>= f = f a- ||| Also called `join` or mu flatten : Monad m => m (m a) -> m a flatten a = a >>= id
libs/prelude/Prelude/Nat.idr view
@@ -195,6 +195,7 @@ instance MinBound Nat where minBound = Z +||| Casts negative `Integers` to 0. instance Cast Integer Nat where cast = fromInteger @@ -238,18 +239,7 @@ instance Monoid Additive where neutral = getAdditive Z -instance MeetSemilattice Nat where- meet = minimum--instance JoinSemilattice Nat where- join = maximum--instance Lattice Nat where { }--instance BoundedJoinSemilattice Nat where- bottom = Z--+||| Casts negative `Ints` to 0. instance Cast Int Nat where cast i = fromInteger (cast i) @@ -333,7 +323,7 @@ ----------------------------------------------------------------------------------- An informative comparison view +-- An informative comparison view -------------------------------------------------------------------------------- data CmpNat : Nat -> Nat -> Type where CmpLT : (y : _) -> CmpNat x (x + S y)
+ libs/prelude/Prelude/Providers.idr view
@@ -0,0 +1,31 @@+module Prelude.Providers++import Prelude.Functor+import Prelude.Applicative+import Prelude.Monad++||| Type providers must build one of these in an IO computation.+public+data Provider : (a : Type) -> Type where+ ||| Return a term to be spliced in+ ||| @ x the term to be spliced (i.e. the proof)+ Provide : (x : a) -> Provider a++ ||| Report an error to the user and stop compilation+ ||| @ msg the error message+ Error : (msg : String) -> Provider a++-- instances+instance Functor Provider where+ map f (Provide a) = Provide (f a)+ map f (Error err) = Error err++instance Applicative Provider where+ (Provide f) <*> (Provide x) = Provide (f x)+ (Provide f) <*> (Error err) = Error err+ (Error err) <*> _ = Error err+ pure = Provide++instance Monad Provider where+ (Provide x) >>= f = f x+ (Error err) >>= _ = Error err
libs/prelude/Prelude/Stream.idr view
@@ -111,7 +111,7 @@ instance Applicative Stream where pure = repeat- (<$>) = zipWith apply+ (<*>) = zipWith apply instance Monad Stream where s >>= f = diag (map f s)
libs/prelude/Prelude/Strings.idr view
@@ -17,8 +17,9 @@ ||| Appends two strings together. |||-||| Idris> "AB" ++ "C"-||| "ABC" : String+||| ```idris example+||| "AB" ++ "C"+||| ``` (++) : String -> String -> String (++) = prim__concat @@ -26,8 +27,9 @@ ||| ||| Doesn't work for empty strings. |||-||| Idris> strHead "A"-||| 'A' : Char+||| ```idris example+||| strHead "A"+||| ``` partial strHead : String -> Char strHead = prim__strHead@@ -36,20 +38,24 @@ ||| ||| Doesn't work for empty strings. |||-||| Idris> strTail "AB"-||| "B" : String-||| Idris> strTail "A"-||| "" : String+||| ```idris example+||| strTail "AB"+||| ```+||| ```idris example+||| strTail "A"+||| ``` partial strTail : String -> String strTail = prim__strTail ||| Adds a character to the front of the specified string. |||-||| Idris> strCons 'A' "B"-||| "AB" : String-||| Idris> strCons 'A' ""-||| "A" : String+||| ```idris example+||| strCons 'A' "B"+||| ```+||| ```idris example+||| strCons 'A' ""+||| ``` strCons : Char -> String -> String strCons = prim__strCons @@ -57,18 +63,21 @@ ||| ||| Precondition: '0 < i < length s' for 'strIndex s i'. |||-||| Idris> strIndex "AB" 1-||| 'B' : Char+||| ```idris example+||| strIndex "AB" 1+||| ``` partial strIndex : String -> Int -> Char strIndex = prim__strIndex ||| Reverses the elements within a String. |||-||| Idris> reverse "ABC"-||| "CBA" : String-||| Idris> reverse ""-||| "" : String+||| ```idris example+||| reverse "ABC"+||| ```+||| ```idris example+||| reverse ""+||| ``` reverse : String -> String reverse = prim__strRev @@ -103,8 +112,9 @@ ||| Turns a string into a list of characters. |||-||| Idris> unpack "ABC"-||| ['A', 'B', 'C'] : List Char+||| ```idris example+||| unpack "ABC"+||| ``` unpack : String -> List Char unpack s with (strM s) unpack "" | StrNil = []@@ -116,8 +126,9 @@ ||| Creates a string of a single character. |||-||| Idris> singleton 'A'-||| "A" : String+||| ```idris example+||| singleton 'A'+||| ``` singleton : Char -> String singleton c = strCons c "" @@ -139,10 +150,12 @@ ||| Splits the string into a part before the predicate ||| returns False and the rest of the string. |||-||| Idris> span (/= 'C') "ABCD"-||| ("AB", "CD") : (String, String)-||| Idris> span (/= 'C') "EFGH"-||| ("EFGH", "") : (String, String)+||| ```idris example+||| span (/= 'C') "ABCD"+||| ```+||| ```idris example+||| span (/= 'C') "EFGH"+||| ``` span : (Char -> Bool) -> String -> (String, String) span p xs with (strM xs) span p "" | StrNil = ("", "")@@ -154,28 +167,33 @@ ||| Splits the string into a part before the predicate ||| returns True and the rest of the string. |||-||| Idris> break (== 'C') "ABCD"-||| ("AB", "CD") : (String, String)-||| Idris> break (== 'C') "EFGH"-||| ("EFGH", "") : (String, String)+||| ```idris example+||| break (== 'C') "ABCD"+||| ```+||| ```idris example+||| break (== 'C') "EFGH"+||| ``` break : (Char -> Bool) -> String -> (String, String) break p = span (not . p) ||| Splits the string into parts with the predicate ||| indicating separator characters. |||-||| Idris> split (== '.') ".AB.C..D"-||| ["", "AB", "C", "", "D"] : List String+||| ```idris example+||| split (== '.') ".AB.C..D"+||| ``` split : (Char -> Bool) -> String -> List String split p xs = map pack (split p (unpack xs)) ||| Removes whitespace (determined with 'isSpace') from ||| the start of the string. |||-||| Idris> ltrim " A\nB"-||| "A\nB" : String-||| Idris> ltrim " \nAB"-||| "AB" : String+||| ```idris example+||| ltrim " A\nB"+||| ```+||| ```idris example+||| ltrim " \nAB"+||| ``` ltrim : String -> String ltrim xs with (strM xs) ltrim "" | StrNil = ""@@ -185,15 +203,17 @@ ||| Removes whitespace (determined with 'isSpace') from ||| the start and end of the string. |||-||| Idris> trim " A\nB C "-||| "A\nB C" : String+||| ```idris example+||| trim " A\nB C "+||| ``` trim : String -> String trim xs = ltrim (reverse (ltrim (reverse xs))) ||| Splits a character list into a list of whitespace separated character lists. |||-||| Idris> words' (unpack " A B C D E ")-||| [['A'], ['B'], ['C'], ['D'], ['E']] : List (List Char)+||| ```idris example+||| words' (unpack " A B C D E ")+||| ``` words' : List Char -> List (List Char) words' s = case dropWhile isSpace s of [] => []@@ -202,15 +222,17 @@ ||| Splits a string into a list of whitespace separated strings. |||-||| Idris> words " A B C D E "-||| ["A", "B", "C", "D", "E"] : List String+||| ```idris example+||| words " A B C D E "+||| ``` words : String -> List String words s = map pack $ words' $ unpack s ||| Splits a character list into a list of newline separated character lists. |||-||| Idris> lines' (unpack "\rA BC\nD\r\nE\n")-||| [['A', ' ', 'B', 'C'], ['D'], ['E']] : List (List Char)+||| ```idris example+||| lines' (unpack "\rA BC\nD\r\nE\n")+||| ``` lines' : List Char -> List (List Char) lines' s = case dropWhile isNL s of [] => []@@ -219,8 +241,9 @@ ||| Splits a string into a list of newline separated strings. |||-||| Idris> lines "\rA BC\nD\r\nE\n"-||| ["A BC", "D", "E"] : List String+||| ```idris example+||| lines "\rA BC\nD\r\nE\n"+||| ``` lines : String -> List String lines s = map pack $ lines' $ unpack s @@ -235,8 +258,9 @@ ||| Joins the character lists by spaces into a single character list. |||-||| Idris> unwords' [['A'], ['B', 'C'], ['D'], ['E']]-||| ['A', ' ', 'B', 'C', ' ', 'D', ' ', 'E'] : List Char+||| ```idris example+||| unwords' [['A'], ['B', 'C'], ['D'], ['E']]+||| ``` unwords' : List (List Char) -> List Char unwords' [] = [] unwords' ws = assert_total (foldr1 addSpace ws)@@ -246,24 +270,28 @@ ||| Joins the strings by spaces into a single string. |||-||| Idris> unwords ["A", "BC", "D", "E"]-||| "A BC D E" : String+||| ```idris example+||| unwords ["A", "BC", "D", "E"]+||| ``` unwords : List String -> String unwords = pack . unwords' . map unpack ||| Returns the length of the string. |||-||| Idris> length ""-||| 0 : Nat-||| Idris> length "ABC"-||| 3 : Nat+||| ```idris example+||| length ""+||| ```+||| ```idris example+||| length "ABC"+||| ``` length : String -> Nat length = fromInteger . prim__zextInt_BigInt . prim_lenString ||| Lowercases all characters in the string. |||-||| Idris> toLower "aBc12!"-||| "abc12!" : String+||| ```idris example+||| toLower "aBc12!"+||| ``` toLower : String -> String toLower x with (strM x) strToLower "" | StrNil = ""@@ -272,14 +300,15 @@ ||| Uppercases all characters in the string. |||-||| Idris> toLower "aBc12!"-||| "ABC12!" : String+||| ```idris example+||| toLower "aBc12!"+||| ``` toUpper : String -> String toUpper x with (strM x) strToLower "" | StrNil = "" strToLower (strCons c cs) | (StrCons c cs) = strCons (toUpper c) (toUpper (assert_smaller (strCons c cs) cs ))- + -------------------------------------------------------------------------------- -- Predicates --------------------------------------------------------------------------------
libs/prelude/Prelude/Traversable.idr view
@@ -8,10 +8,10 @@ import Prelude.Functor traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()-traverse_ f = foldr (($>) . f) (pure ())+traverse_ f = foldr ((*>) . f) (pure ()) sequence_ : (Foldable t, Applicative f) => t (f a) -> f ()-sequence_ = foldr ($>) (pure ())+sequence_ = foldr (*>) (pure ()) for_ : (Foldable t, Applicative f) => t a -> (a -> f b) -> f () for_ = flip traverse_
libs/prelude/prelude.ipkg view
@@ -8,9 +8,9 @@ Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either, Prelude.Strings, Prelude.Chars, Prelude.Functor, Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,- Prelude.Uninhabited, Prelude.Pairs,+ Prelude.Uninhabited, Prelude.Pairs, Prelude.Providers, - Language.Reflection, Language.Reflection.Errors,+ Language.Reflection, Language.Reflection.Errors, Language.Reflection.Tactical, Decidable.Equality
rts/Makefile view
@@ -18,7 +18,7 @@ endif ifeq ($(OS), windows)- OBJS += windows/idris_stdfgn.o windows/idris_net.o+ OBJS += windows/idris_stdfgn.o windows/idris_net.o windows/win_utils.o else OBJS += idris_stdfgn.o idris_net.o endif
rts/idris_gc.c view
@@ -17,7 +17,6 @@ } else { allocCon(cl, vm, CTAG(x), ar, 1); for(i = 0; i < ar; ++i) {- // *argptr = copy(vm, *((VAL*)(x->info.c.args)+i)); // recursive version cl->info.c.args[i] = x->info.c.args[i]; } }@@ -90,9 +89,7 @@ case CON: ar = ARITY(heap_item); for(i = 0; i < ar; ++i) {- // printf("Copying %d %p\n", heap_item->info.c.tag, *argptr); VAL newptr = copy(vm, heap_item->info.c.args[i]);- // printf("Got %p\t\t%p %p\n", newptr, scan, vm->heap_next); heap_item->info.c.args[i] = newptr; } break;@@ -111,24 +108,12 @@ void idris_gc(VM* vm) { HEAP_CHECK(vm) STATS_ENTER_GC(vm->stats, vm->heap.size)- // printf("Collecting\n"); if (vm->heap.old != NULL) free(vm->heap.old); - char* newheap = malloc(vm->heap.size);- char* oldheap = vm->heap.heap;-- vm->heap.heap = newheap;-#ifdef FORCE_ALIGNMENT- if (((i_int)(vm->heap.heap)&1) == 1) {- vm->heap.next = newheap + 1;- } else-#endif- {- vm->heap.next = newheap;- }- vm->heap.end = newheap + vm->heap.size;+ /* Allocate swap heap. */+ alloc_heap(&vm->heap, vm->heap.size, vm->heap.growth, vm->heap.heap); VAL* root; @@ -137,10 +122,13 @@ } #ifdef HAS_PTHREAD- for(root = vm->inbox_ptr; root < vm->inbox_write; ++root) {- *root = copy(vm, *root);+ Msg* msg;++ for(msg = vm->inbox; msg < vm->inbox_write; ++msg) {+ msg->msg = copy(vm, msg->msg); } #endif+ vm->ret = copy(vm, vm->ret); vm->reg1 = copy(vm, vm->reg1); @@ -152,7 +140,6 @@ if ((vm->heap.next - vm->heap.heap) > vm->heap.size >> 1) { vm->heap.size += vm->heap.growth; }- vm->heap.old = oldheap; STATS_LEAVE_GC(vm->stats, vm->heap.size, vm->heap.next - vm->heap.heap) HEAP_CHECK(vm)@@ -160,13 +147,13 @@ void idris_gcInfo(VM* vm, int doGC) { printf("Stack: <BOT %p> <TOP %p>\n", vm->valstack, vm->valstack_top);- printf("Final heap size %d\n", (int)(vm->heap.size));- printf("Final heap use %d\n", (int)(vm->heap.next - vm->heap.heap));+ printf("Final heap size %zd\n", vm->heap.size);+ printf("Final heap use %zd\n", vm->heap.next - vm->heap.heap); if (doGC) { idris_gc(vm); }- printf("Final heap use after GC %d\n", (int)(vm->heap.next - vm->heap.heap));+ printf("Final heap use after GC %zd\n", vm->heap.next - vm->heap.heap); #ifdef IDRIS_ENABLE_STATS printf("Total allocations %" PRIu64 "\n", vm->stats.allocations); #endif- printf("Number of collections %d\n", vm->stats.collections);+ printf("Number of collections %" PRIu32 "\n", vm->stats.collections); }
rts/idris_gmp.c view
@@ -27,6 +27,7 @@ mpz_t* bigint; VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);+ idris_doneAlloc(); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init(*bigint);@@ -43,6 +44,7 @@ mpz_t* bigint; VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);+ idris_doneAlloc(); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init(*bigint);@@ -59,6 +61,7 @@ mpz_t* bigint; VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);+ idris_doneAlloc(); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init_set(*bigint, *((mpz_t*)big));@@ -74,6 +77,7 @@ mpz_t* bigint; VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);+ idris_doneAlloc(); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init_set_ui(*bigint, val);@@ -89,6 +93,7 @@ mpz_t* bigint; VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);+ idris_doneAlloc(); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init_set_si(*bigint, val);@@ -105,6 +110,7 @@ if (ISINT(x)) { mpz_t* bigint; VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);+ idris_doneAlloc(); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init(*bigint);@@ -115,6 +121,7 @@ return cl; } else {+ idris_doneAlloc(); switch(GETTY(x)) { case FWD: return GETBIG(vm, x->info.ptr);@@ -129,6 +136,7 @@ mpz_t* bigint; VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);+ idris_doneAlloc(); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_add(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT);@@ -141,6 +149,7 @@ mpz_t* bigint; VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);+ idris_doneAlloc(); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_sub(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT);@@ -153,6 +162,7 @@ mpz_t* bigint; VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);+ idris_doneAlloc(); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_mul(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT);@@ -165,6 +175,7 @@ mpz_t* bigint; VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);+ idris_doneAlloc(); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_tdiv_q(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT);@@ -177,6 +188,7 @@ mpz_t* bigint; VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);+ idris_doneAlloc(); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_mod(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT);@@ -258,8 +270,6 @@ } int bigEqConst(VAL x, int c) {- idris_requireAlloc(IDRIS_MAXGMP);- if (ISINT(x)) { return (GETINT(x) == c); } else { int rv = mpz_cmp_si(GETMPZ(x), c);
rts/idris_heap.c view
@@ -5,13 +5,15 @@ #include <stddef.h> #include <stdio.h> -void alloc_heap(Heap * h, size_t heap_size) ++/* Used for initializing the heap. */+void alloc_heap(Heap * h, size_t heap_size, size_t growth, char * old) { char * mem = malloc(heap_size); if (mem == NULL) { fprintf(stderr, - "RTS ERROR: Unable to allocate heap. Requested %d bytes.\n",- (int)heap_size);+ "RTS ERROR: Unable to allocate heap. Requested %zd bytes.\n",+ heap_size); exit(EXIT_FAILURE); } @@ -27,9 +29,9 @@ h->end = h->heap + heap_size; h->size = heap_size;- h->growth = heap_size;+ h->growth = growth; - h->old = NULL;+ h->old = old; } void free_heap(Heap * h) {@@ -39,6 +41,7 @@ free(h->old); } }+ // TODO: more testing /******************** Heap testing ********************************************/
rts/idris_heap.h view
@@ -14,7 +14,7 @@ } Heap; -void alloc_heap(Heap * heap, size_t heap_size);+void alloc_heap(Heap * heap, size_t heap_size, size_t growth, char * old); void free_heap(Heap * heap);
rts/idris_rts.c view
@@ -1,11 +1,4 @@-#include <stdlib.h>-#include <stdio.h>-#include <string.h>-#include <stdarg.h> #include <assert.h>-#ifdef HAS_PTHREAD-#include <pthread.h>-#endif #include "idris_rts.h" #include "idris_gc.h"@@ -36,7 +29,7 @@ vm->valstack_base = valstack; vm->stack_max = valstack + stack_size; - alloc_heap(&(vm->heap), heap_size);+ alloc_heap(&(vm->heap), heap_size, heap_size, NULL); vm->ret = NULL; vm->reg1 = NULL;@@ -44,7 +37,6 @@ vm->inbox = malloc(1024*sizeof(VAL)); memset(vm->inbox, 0, 1024*sizeof(VAL)); vm->inbox_end = vm->inbox + 1024;- vm->inbox_ptr = vm->inbox; vm->inbox_write = vm->inbox; // The allocation lock must be reentrant. The lock exists to ensure that@@ -71,8 +63,24 @@ return vm; } +VM* idris_vm() {+ VM* vm = init_vm(4096000, 4096000, 1);+ init_threadkeys();+ init_threaddata(vm);+ init_gmpalloc();+ init_nullaries();++ return vm;+}++void close_vm(VM* vm) {+ terminate(vm);+}+ void init_threadkeys() {+#ifdef HAS_PTHREAD pthread_key_create(&vm_key, (void*)free_key);+#endif } void init_threaddata(VM *vm) {@@ -613,8 +621,16 @@ { /* Make the buffer bigger and read more of the line */ line_buf_size += BUFSIZE;- line_buf = (char *) realloc (line_buf, line_buf_size);-+ { /* 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 */@@ -1005,7 +1021,7 @@ // VM is assumed to be a different vm from the one x lives on -VAL copyTo(VM* vm, VAL x) {+VAL doCopyTo(VM* vm, VAL x) { int i, ar; VAL* argptr; Closure* cl;@@ -1022,7 +1038,7 @@ argptr = (VAL*)(cl->info.c.args); for(i = 0; i < ar; ++i) {- *argptr = copyTo(vm, *((VAL*)(x->info.c.args)+i)); // recursive version+ *argptr = doCopyTo(vm, *((VAL*)(x->info.c.args)+i)); // recursive version argptr++; } }@@ -1063,6 +1079,14 @@ return cl; } +VAL copyTo(VM* vm, VAL x) {+ VM* current = pthread_getspecific(vm_key);+ pthread_setspecific(vm_key, vm);+ VAL ret = doCopyTo(vm, x);+ pthread_setspecific(vm_key, current);+ return ret;+}+ // Add a message to another VM's message queue void idris_sendMessage(VM* sender, VM* dest, VAL msg) { // FIXME: If GC kicks in in the middle of the copy, we're in trouble.@@ -1088,18 +1112,19 @@ } pthread_mutex_lock(&(dest->inbox_lock));- *(dest->inbox_write) = dmsg;-- dest->inbox_write++;+ if (dest->inbox_write >= dest->inbox_end) {- dest->inbox_write = dest->inbox;- }-- if (dest->inbox_write == dest->inbox_ptr) {- fprintf(stderr, "Inbox full"); // Maybe grow it instead...+ // FIXME: This is obviously bad in the long run. This should+ // either block, make the inbox bigger, or return an error code,+ // or possibly make it user configurable+ fprintf(stderr, "Inbox full"); exit(-1); } + dest->inbox_write->msg = dmsg;+ dest->inbox_write->sender = sender;+ dest->inbox_write++;+ // Wake up the other thread pthread_mutex_lock(&dest->inbox_block); pthread_cond_signal(&dest->inbox_waiting);@@ -1111,19 +1136,47 @@ // printf("Sending [unlock]...\n"); } -int idris_checkMessages(VM* vm) {- VAL msg = *(vm->inbox_ptr);- return (msg != NULL);+VM* idris_checkMessages(VM* vm) {+ return idris_checkMessagesFrom(vm, NULL); } +VM* idris_checkMessagesFrom(VM* vm, VM* sender) {+ Msg* msg;+ + for (msg = vm->inbox; msg < vm->inbox_end && msg->msg != NULL; ++msg) {+ if (sender == NULL || msg->sender == sender) {+ return msg->sender;+ }+ }+ return 0;+}++Msg* idris_getMessageFrom(VM* vm, VM* sender) {+ Msg* msg;+ + for (msg = vm->inbox; msg < vm->inbox_write; ++msg) {+ if (sender == NULL || msg->sender == sender) {+ return msg;+ }+ }+ return NULL;+}+ // block until there is a message in the queue-VAL idris_recvMessage(VM* vm) {- VAL msg;+Msg* idris_recvMessage(VM* vm) {+ return idris_recvMessageFrom(vm, NULL);+}++Msg* idris_recvMessageFrom(VM* vm, VM* sender) {+ Msg* msg;+ Msg* ret = malloc(sizeof(Msg));+ struct timespec timeout; int status; pthread_mutex_lock(&vm->inbox_block);- msg = *(vm->inbox_ptr);+ msg = idris_getMessageFrom(vm, sender);+ while (msg == NULL) { // printf("No message yet\n"); // printf("Waiting [lock]...\n");@@ -1133,26 +1186,53 @@ &timeout); (void)(status); //don't emit 'unused' warning // printf("Waiting [unlock]... %d\n", status);- msg = *(vm->inbox_ptr);+ msg = idris_getMessageFrom(vm, sender); } pthread_mutex_unlock(&vm->inbox_block); if (msg != NULL) {+ ret->msg = msg->msg;+ ret->sender = msg->sender;+ pthread_mutex_lock(&(vm->inbox_lock));- *(vm->inbox_ptr) = NULL;- vm->inbox_ptr++;- if (vm->inbox_ptr >= vm->inbox_end) {- vm->inbox_ptr = vm->inbox;++ // Slide everything down after the message in the inbox,+ // Move the inbox_write pointer down, and clear the value at the+ // end - O(n) but it's easier since the message from a specific+ // sender could be anywhere in the inbox++ for(;msg < vm->inbox_write; ++msg) {+ if (msg+1 != vm->inbox_end) {+ msg->sender = (msg + 1)->sender;+ msg->msg = (msg + 1)->msg;+ } }++ vm->inbox_write->msg = NULL;+ vm->inbox_write->sender = NULL;+ vm->inbox_write--;+ pthread_mutex_unlock(&(vm->inbox_lock)); } else { fprintf(stderr, "No messages waiting"); exit(-1); } - return msg;+ return ret; } #endif++VAL idris_getMsg(Msg* msg) {+ return msg->msg;+}++VM* idris_getSender(Msg* msg) {+ return msg->sender;+}++void idris_freeMsg(Msg* msg) {+ free(msg);+} VAL* nullary_cons;
rts/idris_rts.h view
@@ -80,7 +80,16 @@ } info; } Closure; -typedef struct {+struct VM_t;++struct Msg_t {+ struct VM_t* sender;+ VAL msg;+};++typedef struct Msg_t Msg;++struct VM_t { VAL* valstack; VAL* valstack_top; VAL* valstack_base;@@ -93,11 +102,9 @@ pthread_mutex_t alloc_lock; pthread_cond_t inbox_waiting; - VAL* inbox; // Block of memory for storing messages- VAL* inbox_end; // End of block of memory-- VAL* inbox_ptr; // Next message to read- VAL* inbox_write; // Location of next message to write+ Msg* inbox; // Block of memory for storing messages+ Msg* inbox_end; // End of block of memory+ Msg* inbox_write; // Location of next message to write int processes; // Number of child processes int max_threads; // maximum number of threads to run in parallel@@ -106,8 +113,10 @@ VAL ret; VAL reg1;-} VM;+}; +typedef struct VM_t VM;+ // Create a new VM VM* init_vm(int stack_size, size_t heap_size, int max_threads);@@ -116,6 +125,11 @@ // Clean up a VM once it's no longer needed Stats terminate(VM* vm); +// Create a new VM, set up everything with sensible defaults (use when+// calling Idris from C)+VM* idris_vm();+void close_vm(VM* vm);+ // Set up key for thread-local data - called once from idris_main void init_threadkeys(); @@ -153,7 +167,7 @@ #define SETTY(x,t) (x)->ty = (((x)->ty & 0xffff0000) | (t)) #define GETHEAP(x) ((x)->ty >> 16)-#define SETHEAP(x,y) (x)->ty = (((x)->ty & 0x0000ffff) | ((t) << 16))+#define SETHEAP(x,y) (x)->ty = (((x)->ty & 0x0000ffff) | ((y) << 16)) // Integers, floats and operators @@ -277,10 +291,21 @@ // Add a message to another VM's message queue void idris_sendMessage(VM* sender, VM* dest, VAL msg);+// Check whether there are any messages in the queue and return PID of+// sender if so (null if not)+VM* idris_checkMessages(VM* vm); // Check whether there are any messages in the queue-int idris_checkMessages(VM* vm);+VM* idris_checkMessagesFrom(VM* vm, VM* sender); // block until there is a message in the queue-VAL idris_recvMessage(VM* vm);+Msg* idris_recvMessage(VM* vm);+// block until there is a message in the queue+Msg* idris_recvMessageFrom(VM* vm, VM* sender);++// Query/free structure used to return message data (recvMessage will malloc,+// so needs an explicit free)+VAL idris_getMsg(Msg* msg);+VM* idris_getSender(Msg* msg);+void idris_freeMsg(Msg* msg); void dumpVal(VAL r); void dumpStack(VM* vm);
rts/idris_stats.h view
@@ -3,9 +3,10 @@ #ifdef IDRIS_ENABLE_STATS #include <time.h>+#endif+ #include <inttypes.h> #include <stdint.h>-#endif // TODO: measure user time, exclusive/inclusive stats
rts/idris_stdfgn.c view
@@ -32,9 +32,13 @@ return ferror(f); } -void fputStr(void* h, char* str) {+int idris_writeStr(void* h, char* str) { FILE* f = (FILE*)h;- fputs(str, f);+ if (fputs(str, f)) {+ return 0;+ } else {+ return -1;+ } } int fpoll(void* h)
rts/idris_stdfgn.h view
@@ -10,7 +10,8 @@ void fileClose(void* h); int fileEOF(void* h); int fileError(void* h);-void fputStr(void*h, char* str);+// return 0 on success+int idris_writeStr(void*h, char* str); void* do_popen(const char* cmd, const char* mode); int fpoll(void* h);
rts/windows/idris_stdfgn.c view
@@ -5,9 +5,12 @@ #include <fcntl.h> #include <stdio.h> #include <time.h>+#include <io.h> extern char** environ; +int win_fpoll(void* h);+ void putStr(char* str) { printf("%s", str); }@@ -32,14 +35,18 @@ return ferror(f); } -void fputStr(void* h, char* str) {+int idris_writeStr(void* h, char* str) { FILE* f = (FILE*)h;- fputs(str, f);+ if (fputs(str, f)) {+ return 0;+ } else {+ return -1;+ } } int fpoll(void* h) {- return 0;+ return win_fpoll(h); } void* do_popen(const char* cmd, const char* mode) {
+ rts/windows/win_utils.c view
@@ -0,0 +1,21 @@+#include <windows.h>+#include <io.h>+#include <stdio.h>++// THis file exists to avoid clashes between windows.h and idris_rts.h+//++int win_fpoll(void* h)+{+ HANDLE wh =(HANDLE) _get_osfhandle(_fileno((FILE*)h));+ if (wh == INVALID_HANDLE_VALUE) {+ return -1;+ }+ DWORD ret = WaitForSingleObject(wh, 1000);+ // Imitate the return values of select()+ if (ret == WAIT_OBJECT_0)+ return 1;+ if (ret == WAIT_TIMEOUT)+ return 0;+ return -1;+}
src/IRTS/Bytecode.hs view
@@ -5,6 +5,7 @@ import IRTS.Lang import IRTS.Simplified+import IRTS.Defunctionalise import Idris.Core.TT import Data.Maybe @@ -69,10 +70,8 @@ -- same, perhaps exists just for TCO | TAILCALL Name - -- set reg to (apply string args), FLang argument is the language to- -- be called. FType is the foreign language type, which may be used to- -- control marshaling.- | FOREIGNCALL Reg FLang FType String [(FType, Reg)]+ -- set reg to (apply string args), + | FOREIGNCALL Reg FDesc FDesc [(FDesc, Reg)] -- move this number of elements from TOP to BASE | SLIDE Int@@ -132,8 +131,8 @@ bc reg (SApp True f vs) r = RESERVE (length vs) : moveReg 0 vs ++ [SLIDE (length vs), TOPBASE (length vs), TAILCALL f]-bc reg (SForeign l t fname args) r- = FOREIGNCALL reg l t fname (map farg args) : clean r+bc reg (SForeign t fname args) r+ = FOREIGNCALL reg t fname (map farg args) : clean r where farg (ty, Loc i) = (ty, L i) bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg]
src/IRTS/CodegenC.hs view
@@ -4,6 +4,7 @@ import IRTS.Bytecode import IRTS.Lang import IRTS.Simplified+import IRTS.Defunctionalise import IRTS.System import IRTS.CodegenCommon import Idris.Core.TT@@ -20,16 +21,22 @@ import System.FilePath ((</>), (<.>)) import Control.Monad +import Debug.Trace+ codegenC :: CodeGenerator-codegenC ci = codegenC' (simpleDecls ci)- (outputFile ci)- (outputType ci)- (includes ci)- (compileObjs ci)- (map mkLib (compileLibs ci) ++- map incdir (importDirs ci))- (compilerFlags ci)- (debugLevel ci)+codegenC ci = do codegenC' (simpleDecls ci)+ (outputFile ci)+ (outputType ci)+ (includes ci)+ (compileObjs ci)+ (map mkLib (compileLibs ci) +++ map incdir (importDirs ci))+ (compilerFlags ci)+ (exportDecls ci)+ (interfaces ci)+ (debugLevel ci)+ when (interfaces ci) $+ codegenH (exportDecls ci) where mkLib l = "-l" ++ l incdir i = "-I" ++ i@@ -41,17 +48,20 @@ [String] -> -- extra object files [String] -> -- extra compiler flags (libraries) [String] -> -- extra compiler flags (anything)+ [ExportIFace] -> + Bool -> -- interfaces too (so make a .o instead) DbgLevel -> IO ()-codegenC' defs out exec incs objs libs flags dbg+codegenC' defs out exec incs objs libs flags exports iface dbg = do -- print defs let bc = map toBC defs let h = concatMap toDecl (map fst bc) let cc = concatMap (uncurry toC) bc+ let hi = concatMap ifaceC (concatMap getExp exports) d <- getDataDir mprog <- readFile (d </> "rts" </> "idris_main" <.> "c") let cout = headers incs ++ debug dbg ++ h ++ cc ++- (if (exec == Executable) then mprog else "")+ (if (exec == Executable) then mprog else hi) case exec of MavenProject -> putStrLn ("FAILURE: output type not supported") Raw -> writeFile out cout@@ -64,21 +74,23 @@ libFlags <- getLibFlags incFlags <- getIncFlags let args = [gccDbg dbg] ++- gccFlags +++ gccFlags iface ++ -- # Any flags defined here which alter the RTS API must also be added to config.mk- ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS",+ ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS", "-msse2", "-I."] ++ objs ++ ["-x", "c"] ++ (if (exec == Executable) then [] else ["-c"]) ++ [tmpn] ++- concatMap words libFlags +++ (if not iface then concatMap words libFlags else []) ++ concatMap words incFlags ++- concatMap words libs +++ (if not iface then concatMap words libs else []) ++ concatMap words flags ++ ["-o", out]--- putStrLn gcc+-- putStrLn (show args) exit <- rawSystem comp args when (exit /= ExitSuccess) $ putStrLn ("FAILURE: " ++ show comp ++ " " ++ show args)+ where+ getExp (Export _ _ exp) = exp headers xs = concatMap@@ -90,7 +102,8 @@ -- We're using signed integers now. Make sure we get consistent semantics -- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/-gccFlags = ["-fwrapv", "-fno-strict-overflow"]+gccFlags i = if i then ["-fwrapv"]+ else ["-fwrapv", "-fno-strict-overflow"] gccDbg DEBUG = "-g" gccDbg TRACE = "-O2"@@ -274,16 +287,41 @@ bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n" bcc i STOREOLD = indent i ++ "STOREOLD;\n" bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"-bcc i (FOREIGNCALL l LANG_C rty fn args)+bcc i (FOREIGNCALL l rty (FStr fn) args) = indent i ++- c_irts rty (creg l ++ " = ")+ c_irts (toFType rty) (creg l ++ " = ") (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"- where fcall (t, arg) = irts_c t (creg arg)+ 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 _ = indent i ++ "// not done yet\n"+-- bcc i c = error (show c) -- indent i ++ "// not done yet\n" +-- Deconstruct the Foreign type in the defunctionalised expression and build+-- a foreign type description for c_irts and irts_c+toAType (FCon i) + | i == sUN "C_IntChar" = ATInt ITChar+ | i == sUN "C_IntNative" = ATInt ITNative+ | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)+ | 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) + | c == sUN "C_Str" = FString+ | c == sUN "C_Float" = FArith ATFloat+ | c == sUN "C_Ptr" = FPtr+ | c == sUN "C_MPtr" = FManagedPtr+ | c == sUN "C_Unit" = FUnit+toFType (FApp c [_,ity]) + | c == sUN "C_IntT" = FArith (toAType ity)+toFType (FApp c [_]) + | c == sUN "C_Any" = FAny+toFType t = FAny c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))" c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x@@ -403,10 +441,16 @@ doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")" doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")" -doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"-doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"-doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"+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]@@ -527,3 +571,100 @@ flUnOp :: String -> String -> String flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"++-------------------- Interface file generation++-- First, the wrappers in the C file++ifaceC :: Export -> String+ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"+ifaceC (ExportFun n cn ret args)+ = ctype ret ++ " " ++ cdesc cn ++ + "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"+ ++ mkBody n (zip argNames args) ret ++ "}\n\n"+ where showArgs [] = ""+ showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n +++ showArgs ts++ argNames = zipWith (++) (repeat "arg") (map show [0..])++mkBody n as t = indent 1 ++ "INITFRAME;\n" +++ indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" +++ push 0 as ++ call n ++ retval t+ where push i [] = ""+ push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t) + ("TOP(" ++ show i ++ ") = ") n+ ++ ";\n" ++ push (i + 1) ts++ call _ = indent 1 ++ "STOREOLD;\n" +++ indent 1 ++ "BASETOP(0);\n" +++ indent 1 ++ "ADDTOP(" ++ show (length as) ++ ");\n" +++ indent 1 ++ "CALL(" ++ cname n ++ ");\n"++ retval (FIO t)+ = indent 1 ++ "TOP(0) = NULL;\n" +++ indent 1 ++ "TOP(1) = NULL;\n" +++ indent 1 ++ "TOP(2) = RVAL;\n" +++ indent 1 ++ "STOREOLD;\n" +++ indent 1 ++ "BASETOP(0);\n" +++ indent 1 ++ "ADDTOP(3);\n" +++ indent 1 ++ "CALL(" ++ cname (sUN "call__IO") ++ ");\n" +++ retval t+ retval t = indent 1 ++ "return " ++ irts_c (toFType t) "RVAL" ++ ";\n"++ctype (FCon c)+ | c == sUN "C_Str" = "char*"+ | c == sUN "C_Float" = "float"+ | c == sUN "C_Ptr" = "void*"+ | c == sUN "C_MPtr" = "void*"+ | c == sUN "C_Unit" = "void"+ctype (FApp c [_,ity])+ | c == sUN "C_IntT" = carith ity+ctype (FApp c [_])+ | c == sUN "C_Any" = "VAL"+ctype (FStr s) = s+ctype FUnknown = "void*"+ctype (FIO t) = ctype t+ctype t = error "Can't happen: Not a valid interface type " ++ show t++carith (FCon i)+ | i == sUN "C_IntChar" = "char"+ | i == sUN "C_IntNative" = "int"+carith t = error "Can't happen: Not an exportable arithmetic type"++cdesc (FStr s) = s+cdesc s = error "Can't happen: Not a valid C name"++-- Then, the header files++codegenH :: [ExportIFace] -> IO ()+codegenH es = mapM_ writeIFace es++writeIFace :: ExportIFace -> IO ()+writeIFace (Export ffic hdr exps)+ | ffic == sUN "FFI_C"+ = do let hfile = "#ifndef " ++ hdr_guard hdr ++ "\n" +++ "#define " ++ hdr_guard hdr ++ "\n\n" +++ "#include <idris_rts.h>\n\n" +++ concatMap hdr_export exps ++ "\n" +++ "#endif\n\n"+ writeFile hdr hfile+ | otherwise = return ()++hdr_guard x = "__" ++ map hchar x+ where hchar x | isAlphaNum x = toUpper x+ hchar _ = '_'++hdr_export :: Export -> String+hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"+hdr_export (ExportFun n cn ret args)+ = ctype ret ++ " " ++ cdesc cn ++ + "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"+ where showArgs [] = ""+ showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n +++ showArgs ts++ argNames = zipWith (++) (repeat "arg") (map show [0..])+++
src/IRTS/CodegenCommon.hs view
@@ -33,7 +33,9 @@ debugLevel :: DbgLevel, simpleDecls :: [(Name, SDecl)], defunDecls :: [(Name, DDecl)],- liftDecls :: [(Name, LDecl)] + liftDecls :: [(Name, LDecl)],+ interfaces :: Bool,+ exportDecls :: [ExportIFace] } type CodeGenerator = CodegenInfo -> IO ()
src/IRTS/CodegenJavaScript.hs view
@@ -8,6 +8,7 @@ import IRTS.Bytecode import IRTS.Lang import IRTS.Simplified+import IRTS.Defunctionalise import IRTS.CodegenCommon import Idris.Core.TT import IRTS.System@@ -541,14 +542,6 @@ jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS jsFOREIGN _ reg n args- | n == "putStr"- , [(FString, arg)] <- args =- JSAssign (- translateReg reg- ) (- JSApp (JSIdent "i$putStr") [translateReg arg]- )- | n == "isNull" , [(FPtr, arg)] <- args = JSAssign (@@ -687,6 +680,10 @@ jsOP' | LNoOp <- op = translateReg (last args) + | LWriteStr <- op,+ (_:str:_) <- args = JSAssign (translateReg reg)+ (JSApp (JSIdent "i$putStr") [translateReg str])+ | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args) | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args) | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)@@ -1332,7 +1329,8 @@ | NULL r <- bc = jsNULL info r | CALL n <- bc = jsCALL info n | TAILCALL n <- bc = jsTAILCALL info n- | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a+ | FOREIGNCALL r _ (FStr n) args + <- bc = jsFOREIGN info r n (map fcall args) | TOPBASE n <- bc = jsTOPBASE info n | BASETOP n <- bc = jsBASETOP info n | STOREOLD <- bc = jsSTOREOLD info@@ -1346,4 +1344,29 @@ | OP r o a <- bc = jsOP info r o a | ERROR e <- bc = jsERROR info e | otherwise = JSRaw $ "//" ++ show bc+ where fcall (t, arg) = (toFType t, arg)++toAType (FCon i) + | i == sUN "JS_IntChar" = ATInt ITChar+ | i == sUN "JS_IntNative" = ATInt ITNative+toAType t = error (show t ++ " not defined in toAType")++toFnType (FApp c [_,_,s,t])+ | c == sUN "JS_Fn" = toFnType t+toFnType (FApp c [_,_,r])+ | c == sUN "JS_FnIO" = FFunctionIO+toFnType (FApp c [_,r])+ | c == sUN "JS_FnBase" = FFunction+toFnType t = error (show t ++ " not defined in toFnType")++toFType (FCon c) + | c == sUN "JS_Str" = FString+ | c == sUN "JS_Float" = FArith ATFloat+ | c == sUN "JS_Ptr" = FPtr+ | c == sUN "JS_Unit" = FUnit+toFType (FApp c [_,ity]) + | c == sUN "JS_IntT" = FArith (toAType ity)+toFType (FApp c [_,fty]) + | c == sUN "JS_FnT" = toFnType fty+toFType t = error (show t ++ " not yet defined in toFType")
src/IRTS/Compiler.hs view
@@ -11,6 +11,7 @@ import IRTS.DumpBC import IRTS.CodegenJavaScript import IRTS.Inliner+import IRTS.Exports import Idris.AbsSyntax import Idris.AbsSyntaxTree@@ -45,20 +46,30 @@ -- | Given a 'main' term to compiler, return the IRs which can be used to -- generate code.-compile :: Codegen -> FilePath -> Term -> Idris CodegenInfo-compile codegen f tm+compile :: Codegen -> FilePath -> Maybe Term -> Idris CodegenInfo+compile codegen f mtm = do checkMVs -- check for undefined metavariables checkTotality -- refuse to compile if there are totality problems- reachableNames <- performUsageAnalysis- maindef <- irMain tm- iLOG $ "MAIN: " ++ show maindef+ exports <- findExports++ reachableNames <- performUsageAnalysis (getExpNames exports)+ maindef <- case mtm of+ Nothing -> return []+ Just tm -> do md <- irMain tm+ iLOG $ "MAIN: " ++ show md+ return [(sMN 0 "runMain", md)] objs <- getObjectFiles codegen libs <- getLibs codegen flags <- getFlags codegen hdrs <- getHdrs codegen impdirs <- allImportDirs- defsIn <- mkDecls tm reachableNames- let defs = defsIn ++ [(sMN 0 "runMain", maindef)]+ defsIn <- mkDecls reachableNames+ -- if no 'main term' given, generate interface files+ let iface = case mtm of+ Nothing -> True+ Just _ -> False++ let defs = defsIn ++ maindef -- iputStrLn $ showSep "\n" (map show defs) -- Inlined top level LDecl made here let defsInlined = inlineAll defs@@ -89,12 +100,11 @@ triple <- Idris.AbsSyntax.targetTriple cpu <- Idris.AbsSyntax.targetCPU iLOG "Building output"- case checked of OK c -> do return $ CodegenInfo f outty triple cpu hdrs impdirs objs libs flags NONE c (toAlist defuns)- tagged+ tagged iface exports -- runIO $ case codegen of -- ViaC -> codegenC cginfo -- ViaJava -> codegenJava cginfo@@ -133,8 +143,8 @@ i <- irTerm M.empty [] tm return $ LFun [] (sMN 0 "runMain") [] (LForce i) -mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]-mkDecls t used+mkDecls :: [Name] -> Idris [(Name, LDecl)]+mkDecls used = do i <- getIState let ds = filter (\(n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i) decls <- mapM build ds@@ -218,7 +228,7 @@ irTerm vs env tm@(App f a) = case unApply tm of (P _ (UN m) _, args) | m == txt "mkForeignPrim"- -> doForeign vs env args+ -> doForeign vs env (reverse (drop 4 args)) -- drop implicits (P _ (UN u) _, [_, arg]) | u == txt "unsafePerformPrimIO"@@ -429,14 +439,37 @@ [t', LConst (BI 1)] irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i+irTerm vs env (Constant TheWorld) = return $ LNothing irTerm vs env (Constant c) = return $ LConst c irTerm vs env (TType _) = return $ LNothing irTerm vs env Erased = return $ LNothing irTerm vs env Impossible = return $ LNothing -doForeign :: Vars -> [Name] -> [TT Name] -> Idris LExp-doForeign vs env (_ : fgn : args)- | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn+doForeign :: Vars -> [Name] -> [Term] -> Idris LExp+doForeign vs env (ret : fname : world : args)+ = do args' <- mapM splitArg args+ let fname' = toFDesc fname + let ret' = toFDesc ret+ return $ LForeign ret' fname' args'+ where+ splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits+ = do let l' = toFDesc l + r' <- irTerm vs env r+ return (l', r')+ splitArg _ = ifail "Badly formed foreign function call"++ toFDesc (Constant (Str str)) = FStr str + toFDesc tm + | (P _ n _, []) <- unApply tm = FCon (deNS n) + | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDesc as)+ toFDesc _ = FUnknown++ deNS (NS n _) = n+ deNS n = n+doForeign vs env xs = ifail "Badly formed foreign function call"++{-+ - | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn = case getFTypes fgnArgTys of Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args) Just tys -> do@@ -502,6 +535,7 @@ mkIntIty "IT16" = FArith (ATInt (ITFixed IT16)) mkIntIty "IT32" = FArith (ATInt (ITFixed IT32)) mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))+-} irTree :: [Name] -> SC -> Idris LExp irTree args tree = do
src/IRTS/Defunctionalise.hs view
@@ -22,7 +22,7 @@ | DCase CaseType DExp [DAlt] | DChkCase DExp [DAlt] -- a case where the type is unknown (for EVAL/APPLY) | DConst Const- | DForeign FLang FType String [(FType, DExp)]+ | DForeign FDesc FDesc [(FDesc, DExp)] | DOp PrimFn [DExp] | DNothing -- erased value, can be compiled to anything since it'll never -- be inspected@@ -110,7 +110,9 @@ alts' <- mapM (aaAlt env) alts return $ DCase up e' alts' aa env (LConst c) = return $ DConst c- aa env (LForeign l t n args) = liftM (DForeign l t n) (mapM (aaF env) args)+ aa env (LForeign t n args) + = do args' <- mapM (aaF env) args+ return $ DForeign t n args' aa env (LOp LFork args) = liftM (DOp LFork) (mapM (aa env) args) aa env (LOp f args) = do args' <- mapM (aa env) args return $ DOp f args'@@ -173,7 +175,7 @@ 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 (DForeign _ _ args) = or (map (needsEval x) (map snd args)) needsEval x (DOp op args) = or (map (needsEval x) args) needsEval x (DProj (DV (Glob x')) _) = x == x' needsEval x _ = False@@ -257,13 +259,13 @@ instance Show DExp where show e = show' [] e where show' env (DV (Loc i)) = "var " ++ env!!i- show' env (DV (Glob n)) = show n+ show' env (DV (Glob n)) = "GLOB " ++ show n show' env (DApp _ e args) = show e ++ "(" ++ showSep ", " (map (show' env) args) ++")" show' env (DLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++ show' (env ++ [show n]) e show' env (DUpdate n e) = "!update " ++ show n ++ "(" ++ show' env e ++ ")"- show' env (DC loc i n args) = atloc loc ++ show n ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"+ show' env (DC loc i n args) = atloc loc ++ "CON " ++ show n ++ "(" ++ showSep ", " (map (show' env) args) ++ ")" where atloc Nothing = "" atloc (Just l) = "@" ++ show (LV l) ++ ":" show' env (DProj t i) = show t ++ "!" ++ show i@@ -275,8 +277,8 @@ show' env (DChkCase e alts) = "case' " ++ show' env e ++ " of {\n\t" ++ showSep "\n\t| " (map (showAlt env) alts) show' env (DConst c) = show c- show' env (DForeign lang ty n args)- = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"+ show' env (DForeign ty n args)+ = "foreign " ++ show n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")" show' env (DOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")" show' env (DError str) = "error " ++ show str show' env DNothing = "____"
src/IRTS/DumpBC.hs view
@@ -51,8 +51,8 @@ maybe "" (\def' -> "\n" ++ serializeDefault (n + 1) def') def CALL x -> "CALL " ++ show x TAILCALL x -> "TAILCALL " ++ show x- FOREIGNCALL r _ ret name args ->- "FOREIGNCALL " ++ serializeReg r ++ " \"" ++ name ++ "\" " ++ show ret +++ FOREIGNCALL r ret name args ->+ "FOREIGNCALL " ++ serializeReg r ++ " \"" ++ show name ++ "\" " ++ show ret ++ " [" ++ interMap args ", " (\(ty, r) -> serializeReg r ++ " : " ++ show ty) ++ "]" SLIDE n -> "SLIDE " ++ show n REBASE -> "REBASE"
+ src/IRTS/Exports.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE PatternGuards #-}+module IRTS.Exports(findExports, getExpNames) where++import Idris.AbsSyntax+import Idris.Core.TT+import Idris.Core.CaseTree+import Idris.Core.Evaluate+import Idris.Error+import IRTS.Lang++import Data.Maybe++findExports :: Idris [ExportIFace]+findExports = do exps <- getExports+ es <- mapM toIFace exps+ logLvl 2 $ "Exporting " ++ show es+ return es++getExpNames :: [ExportIFace] -> [Name]+getExpNames = concatMap expNames++expNames :: ExportIFace -> [Name]+expNames (Export _ _ es) = mapMaybe fnames es+ where fnames (ExportData _) = Nothing+ fnames (ExportFun n _ _ _) = Just n++toIFace :: Name -> Idris ExportIFace+toIFace n = do i <- getIState+ let ctxt = tt_ctxt i+ def <- case lookupDefExact n ctxt of+ Just (CaseOp _ _ _ _ _ cs)+ -> getExpList (snd (cases_compiletime cs))+ Nothing -> ifail "Can't happen [toIFace]"+ case lookupTyExact n ctxt of+ Just ty -> toIFaceTyVal ty def+ Nothing -> ifail "Can't happen [toIFace]"+ where+ getExpList (STerm t) = return t+ getExpList _ = ifail "Badly formed export list"++toIFaceTyVal :: Type -> Term -> Idris ExportIFace+toIFaceTyVal ty tm + | (P _ exp _, [P _ ffi _, Constant (Str hdr), _]) <- unApply ty+ = do tm' <- toIFaceVal tm+ return $ Export ffi hdr tm'++toIFaceVal :: Term -> Idris [Export]+toIFaceVal tm+ | (P _ end _, _) <- unApply tm,+ end == sNS (sUN "End") ["FFI_Export"] = return []+ | (P _ fun _, [_,_,_,_,(P _ fn _),extnm,prf,rest]) <- unApply tm,+ fun == sNS (sUN "Fun") ["FFI_Export"]+ = do rest' <- toIFaceVal rest+ return $ + ExportFun fn (toFDesc extnm) (toFDescRet prf) (toFDescArgs prf)+ : rest'+ | (P _ dat _, [_,_,_,_,d,rest]) <- unApply tm,+ dat == sNS (sUN "Data") ["FFI_Export"]+ = do rest' <- toIFaceVal rest+ return $ ExportData (toFDesc d) : rest'+ | otherwise = ifail $ "Badly formed export list " ++ show tm++toFDesc :: Term -> FDesc+toFDesc (Constant (Str str)) = FStr str+toFDesc tm+ | (P _ n _, []) <- unApply tm = FCon (deNS n) + | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDesc as)+toFDesc _ = FUnknown++toFDescRet :: Term -> FDesc+toFDescRet tm+ | (P _ ret _, [_,_,_,b]) <- unApply tm,+ ret == sNS (sUN "FFI_Ret") ["FFI_Export"]+ = toFDescBase b+ | (P _ io _, [_,_,_,b]) <- unApply tm,+ io == sNS (sUN "FFI_IO") ["FFI_Export"]+ = FIO $ toFDescBase b+ | (P _ fun _, [_,_,_,_,_,t]) <- unApply tm,+ fun == sNS (sUN "FFI_Fun") ["FFI_Export"]+ = toFDescRet t+ | otherwise = error "Badly formed export proof"++toFDescBase :: Term -> FDesc+toFDescBase tm+ | (P _ prim _, [_, _, _, pdesc]) <- unApply tm,+ prim == sNS (sUN "FFI_Prim") ["FFI_Export"]+ = toFDescPrim pdesc+ | (P _ prim _, [_, _, _, ddesc, _]) <- unApply tm,+ prim == sNS (sUN "FFI_ExpType") ["FFI_Export"]+ = toFDescPrim ddesc+ | otherwise = error "Badly formed export type"++toFDescArgs :: Term -> [FDesc]+toFDescArgs tm + | (P _ fun _, [_,_,_,_,b,t]) <- unApply tm,+ fun == sNS (sUN "FFI_Fun") ["FFI_Export"]+ = toFDescBase b : toFDescArgs t+ | otherwise = []++toFDescPrim (Constant (Str str)) = FStr str +toFDescPrim tm + | (P _ n _, []) <- unApply tm = FCon (deNS n) + | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDescPrim as)+toFDescPrim _ = FUnknown++deNS (NS n _) = n+deNS n = n+++
src/IRTS/Lang.hs view
@@ -29,12 +29,33 @@ Int Name [LExp] | LCase CaseType LExp [LAlt] | LConst Const- | LForeign FLang FType String [(FType, LExp)]+ | LForeign FDesc -- Function descriptor (usually name as string)+ FDesc -- Return type descriptor+ [(FDesc, LExp)] -- first LExp is the FFI type description | LOp PrimFn [LExp] | LNothing | LError String deriving Eq +data FDesc = FCon Name+ | FStr String+ | FUnknown+ | FIO FDesc+ | FApp Name [FDesc]+ deriving (Show, Eq)++data Export = ExportData FDesc -- Exported data descriptor (usually string)+ | ExportFun Name -- Idris name+ FDesc -- Exported function descriptor+ FDesc -- Return type descriptor+ [FDesc] -- Argument types+ deriving (Show, Eq)++data ExportIFace = Export Name -- FFI descriptor+ String -- interface file+ [Export]+ deriving (Show, Eq)+ -- Primitive operators. Backends are not *required* to implement all -- of these, but should report an error if they are unable @@ -48,7 +69,7 @@ | LStrConcat | LStrLt | LStrEq | LStrLen | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy- | LPrintNum | LPrintStr | LReadStr+ | LReadStr | LWriteStr | LReadFile | LWriteFile | LBitCast ArithTy ArithTy -- Only for values of equal width | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan@@ -85,9 +106,6 @@ data FCallType = FStatic | FObject | FConstructor deriving (Show, Eq) -data FLang = LANG_C | LANG_JAVA FCallType- deriving (Show, Eq)- data FType = FArith ArithTy | FFunction | FFunctionIO@@ -192,8 +210,8 @@ liftA (LDefaultCase e) = do e' <- lift env e return (LDefaultCase e') lift env (LConst c) = return (LConst c)-lift env (LForeign l t s args) = do args' <- mapM (liftF env) args- return (LForeign l t s args')+lift env (LForeign t s args) = do args' <- mapM (liftF env) args+ return (LForeign t s args') where liftF env (t, e) = do e' <- lift env e return (t, e')@@ -231,9 +249,9 @@ = do avail <- get v <- findVar [] avail (length es) LCon v i n <$> mapM findUp es- findUp (LForeign l t s es)- = LForeign l t s <$> mapM (\ (t, e) -> do e' <- findUp e- return (t, e')) es+ findUp (LForeign t s es)+ = LForeign t s <$> mapM (\ (t, e) -> do e' <- findUp e+ return (t, e')) es findUp (LOp o es) = LOp o <$> mapM findUp es findUp (LCase Updatable e@(LV (Glob n)) as) = LCase Updatable e <$> mapM (doUpAlt n) as@@ -276,13 +294,16 @@ usedIn env (LForce e) = usedIn env e usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e usedIn env (LLam ns e) = usedIn (env \\ ns) e-usedIn env (LCon loc i n args) = concatMap (usedIn env) args+usedIn env (LCon v i n args) = let rest = concatMap (usedIn env) args in+ case v of+ Nothing -> rest + Just (Glob n) -> usedArg env n ++ rest usedIn env (LProj t i) = usedIn env t usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts where usedInA env (LConCase i n ns e) = usedIn env e usedInA env (LConstCase c e) = usedIn env e usedInA env (LDefaultCase e) = usedIn env e-usedIn env (LForeign _ _ _ args) = concatMap (usedIn env) (map snd args)+usedIn env (LForeign _ _ args) = concatMap (usedIn env) (map snd args) usedIn env (LOp f args) = concatMap (usedIn env) args usedIn env _ = [] @@ -329,9 +350,9 @@ show' env ind (LConst c) = show c - show' env ind (LForeign lang ty n args) = concat+ show' env ind (LForeign ty n args) = concat [ "foreign{ "- , n ++ "("+ , show n ++ "(" , showSep ", " (map (\(ty,x) -> show' env ind x ++ " : " ++ show ty) args) , ") : " , show ty
src/IRTS/LangOpts.hs view
@@ -64,9 +64,9 @@ inlineWith (n : done) (zip args es' ++ env) body inlineWith done env (LApp t f es) = LApp t <$> inlineWith done env f <*> mapM (inlineWith done env) es- inlineWith done env (LForeign l t s args)- = LForeign l t s <$> mapM (\(t, e) -> do e' <- inlineWith done env e- return (t, e')) args+ inlineWith done env (LForeign t s args)+ = LForeign t s <$> mapM (\(t, e) -> do e' <- inlineWith done env e+ return (t, e')) args inlineWith done env t = return t inlineWithAlt done env (LConCase i n es rhs)
src/IRTS/Simplified.hs view
@@ -22,7 +22,9 @@ | SChkCase LVar [SAlt] | SProj LVar Int | SConst Const- | SForeign FLang FType String [(FType, LVar)]+ -- Keep DExps for describing foreign things, because they get+ -- translated differently+ | SForeign FDesc FDesc [(FDesc, LVar)] | SOp PrimFn [LVar] | SNothing -- erased value, will never be inspected | SError String@@ -54,10 +56,10 @@ _ -> return $ SV (Glob x) simplify tl (DApp tc n args) = do args' <- mapM sVar args mkapp (SApp (tl || tc) n) args'-simplify tl (DForeign lang ty fn args)+simplify tl (DForeign ty fn args) = do args' <- mapM sVar (map snd args) let fargs = zip (map fst args) args'- mkfapp (SForeign lang ty fn) fargs+ mkfapp (SForeign ty fn) fargs simplify tl (DLet n v e) = do v' <- simplify False v e' <- simplify tl e return (SLet (Glob n) v' e')@@ -159,10 +161,10 @@ " has arity " ++ show ar Just _ -> return $ SApp tc f args' Nothing -> failsc $ "No such variable " ++ show f- sc env (SForeign l ty f args)+ sc env (SForeign ty f args) = do args' <- mapM (\ (t, a) -> do a' <- scVar env a return (t, a')) args- return $ SForeign l ty f args'+ return $ SForeign ty f args' sc env (SCon loc tag f args) = do loc' <- case loc of Nothing -> return Nothing
src/IRTS/System.hs view
@@ -53,7 +53,8 @@ return $ ["-L" ++ (dir </> "rts"), "-lidris_rts"] ++ extraLib ++ gmpLib ++ ["-lpthread"] -getIdrisLibDir = do dir <- getDataDir+getIdrisLibDir = do libPath <- environment "IDRIS_LIBRARY_PATH"+ dir <- maybe getDataDir return libPath return $ addTrailingPathSeparator dir #if defined(FREEBSD) || defined(DRAGONFLY)
src/Idris/AbsSyntax.hs view
@@ -10,7 +10,7 @@ import Idris.AbsSyntaxTree import Idris.Colours import Idris.Docstrings-import Idris.IdeSlave hiding (Opt(..))+import Idris.IdeMode hiding (Opt(..)) import IRTS.CodegenCommon import Util.DynamicLinker @@ -19,7 +19,6 @@ import Control.Applicative import Control.Monad.State-import Control.Monad.Except (throwError, catchError) import Data.List hiding (insert,union) import Data.Char@@ -97,7 +96,7 @@ addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i } addImported :: Bool -> FilePath -> Idris ()-addImported pub f +addImported pub f = do i <- getIState putIState $ i { idris_imported = nub $ (f, pub) : idris_imported i } @@ -126,6 +125,34 @@ addErrRev t = do i <- getIState putIState $ i { idris_errRev = t : idris_errRev i } +addErasureUsage :: Name -> Int -> Idris ()+addErasureUsage n i = do ist <- getIState+ putIState $ ist { idris_erasureUsed = (n, i) : idris_erasureUsed ist }++addExport :: Name -> Idris ()+addExport n = do ist <- getIState+ putIState $ ist { idris_exports = n : idris_exports ist }++addUsedName :: FC -> Name -> Name -> Idris ()+addUsedName fc n arg+ = do ist <- getIState+ case lookupTyName n (tt_ctxt ist) of+ [(n', ty)] -> addUsage n' 0 ty+ [] -> throwError (At fc (NoSuchVariable n))+ xs -> throwError (At fc (CantResolveAlts (map fst xs)))+ where addUsage n i (Bind x _ sc) | x == arg = do addIBC (IBCUsage (n, i))+ addErasureUsage n i+ | otherwise = addUsage n (i + 1) sc+ addUsage _ _ _ = throwError (At fc (Msg ("No such argument name " ++ show arg)))++getErasureUsage :: Idris [(Name, Int)]+getErasureUsage = do ist <- getIState;+ return (idris_erasureUsed ist)++getExports :: Idris [Name]+getExports = do ist <- getIState+ return (idris_exports ist)+ totcheck :: (FC, Name) -> Idris () totcheck n = do i <- getIState; putIState $ i { idris_totcheck = idris_totcheck i ++ [n] } @@ -241,7 +268,7 @@ where errWhen True = throwError (At fc- (CantUnify False x y (Msg "") [] 0))+ (CantUnify False (x, Nothing) (y, Nothing) (Msg "") [] 0)) errWhen False = return () isTyInferred :: Name -> Idris Bool@@ -333,10 +360,10 @@ addInstance int n i = do ist <- getIState case lookupCtxt n (idris_classes ist) of- [CI a b c d e ins] ->- do let cs = addDef n (CI a b c d e (addI i ins)) (idris_classes ist)+ [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] []) (idris_classes ist) putIState $ ist { idris_classes = cs } where addI i ins | int = i : ins | chaser n = ins ++ [i]@@ -428,6 +455,10 @@ putIState :: IState -> Idris () putIState = put +updateIState :: (IState -> IState) -> Idris ()+updateIState f = do i <- getIState+ putIState $ f i+ withContext :: (IState -> Ctxt a) -> Name -> b -> (a -> Idris b) -> Idris b withContext ctx name dflt action = do ist <- getIState@@ -520,7 +551,16 @@ addDeferred = addDeferred' Ref addDeferredTyCon = addDeferred' (TCon 0 0) -addDeferred' :: NameType -> [(Name, (Int, Maybe Name, Type, Bool))] -> Idris ()+-- | Save information about a name that is not yet defined+addDeferred' :: NameType+ -> [(Name, (Int, Maybe Name, Type, Bool))]+ -- ^ The Name is the name being made into a metavar,+ -- the Int is the number of vars that are part of a+ -- putative proof context, the Maybe Name is the+ -- top-level function containing the new metavariable,+ -- the Type is its type, and the Bool is whether :p is+ -- allowed+ -> Idris () addDeferred' nt ns = do mapM_ (\(n, (i, _, t, _)) -> updateContext (addTyDecl n nt (tidyNames S.empty t))) ns mapM_ (\(n, _) -> when (not (n `elem` primDefs)) $ addIBC (IBCMetavar n)) ns@@ -566,12 +606,6 @@ setWidth w = do ist <- getIState put ist { idris_consolewidth = w } -renderWidth :: Idris Int-renderWidth = do iw <- getWidth- case iw of- InfinitelyWide -> return 100000000- ColsWide n -> return (max n 1)- AutomaticWidth -> runIO getScreenWidth @@ -582,7 +616,7 @@ isetPrompt :: String -> Idris () isetPrompt p = do i <- getIState case idris_outputmode i of- IdeSlave n h -> runIO . hPutStrLn h $ convSExp "set-prompt" p n+ IdeMode n h -> runIO . hPutStrLn h $ convSExp "set-prompt" p n -- | Tell clients how much was parsed and loaded isetLoadedRegion :: Idris ()@@ -591,7 +625,7 @@ case span of Just fc -> case idris_outputmode i of- IdeSlave n h ->+ IdeMode n h -> runIO . hPutStrLn h $ convSExp "set-loaded-region" fc n Nothing -> return ()@@ -733,10 +767,12 @@ outputTy = do i <- getIState return $ opt_outputTy $ idris_options i -setIdeSlave :: Bool -> Handle -> Idris ()-setIdeSlave True h = do i <- getIState- putIState $ i { idris_outputmode = (IdeSlave 0 h), idris_colourRepl = False }-setIdeSlave False _ = return ()+setIdeMode :: Bool -> Handle -> Idris ()+setIdeMode True h = do i <- getIState+ putIState $ i { idris_outputmode = IdeMode 0 h+ , idris_colourRepl = False+ }+setIdeMode False _ = return () setTargetTriple :: String -> Idris () setTargetTriple t = do i <- getIState@@ -851,7 +887,7 @@ when (lvl >= l) $ case idris_outputmode i of RawOutput h -> do runIO $ hPutStrLn h str- IdeSlave n h ->+ IdeMode n h -> do let good = SexpList [IntegerAtom (toInteger l), toSExp str] runIO . hPutStrLn h $ convSExp "log" good n @@ -953,6 +989,7 @@ 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 t = t nselem x [] = False@@ -995,7 +1032,7 @@ (map (expandParams dec ps'' ns' []) ws) (expandParams dec ps'' ns' [] rhs) (map (expandParamsD True ist dec ps'' ns') ds)- expandParamsC (PWith fc n lhs ws wval ds)+ expandParamsC (PWith fc n lhs ws wval pn ds) = let -- ps' = updateps True (namesIn ist wval) (zip ps [0..]) ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..]) lhs' = if rhsonly then lhs else (expandParams dec ps'' ns [] lhs)@@ -1004,6 +1041,7 @@ PWith fc n' lhs' (map (expandParams dec ps'' ns' []) ws) (expandParams dec ps'' ns' [] wval)+ pn (map (expandParamsD rhsonly ist dec ps'' ns') ds) updateps yn nm [] = [] updateps yn nm (((a, t), i):as)@@ -1044,15 +1082,16 @@ -- (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 decls)+expandParamsD rhs ist dec ps ns (PClass doc info f cs n params pDocs fds decls) = PClass doc info f (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs) n (map (mapsnd (expandParams dec ps ns [])) params) pDocs+ fds (map (expandParamsD rhs ist dec ps ns) decls)-expandParamsD rhs ist dec ps ns (PInstance info f cs n params ty cn decls)- = PInstance info f+expandParamsD rhs ist dec ps ns (PInstance doc argDocs info f cs n params ty cn decls)+ = PInstance doc argDocs info f (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs) n (map (expandParams dec ps ns []) params)@@ -1269,8 +1308,10 @@ getImps (Bind n (Pi _ t _) sc) imps | Just (p, t') <- lookup n imps = argInfo n p t' : getImps sc imps where+ argInfo n (Imp opt _ _ _) Placeholder+ = (True, PImp 0 True opt n Placeholder) argInfo n (Imp opt _ _ _) t'- = (True, PImp (getPriority i t') True opt n t')+ = (False, PImp (getPriority i t') True opt n t') argInfo n (Exp opt _ _) t' = (InaccessibleArg `elem` opt, PExp (getPriority i t') opt n t')@@ -1422,6 +1463,7 @@ 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 _ = return () pibind using [] sc = sc@@ -1433,31 +1475,34 @@ -- Add implicit arguments in function calls addImplPat :: IState -> PTerm -> PTerm-addImplPat = addImpl' True [] []+addImplPat = addImpl' True [] [] [] addImplBound :: IState -> [Name] -> PTerm -> PTerm-addImplBound ist ns = addImpl' False ns [] ist+addImplBound ist ns = addImpl' False ns [] [] ist addImplBoundInf :: IState -> [Name] -> [Name] -> PTerm -> PTerm-addImplBoundInf ist ns inf = addImpl' False ns inf ist+addImplBoundInf ist ns inf = addImpl' False ns inf [] ist -- | Add the implicit arguments to applications in the term-addImpl :: IState -> PTerm -> PTerm+-- [Name] gives the names to always expend, even when under a binder of+-- that name (this is to expand methods with implicit arguments in dependent+-- type classes).+addImpl :: [Name] -> IState -> PTerm -> PTerm addImpl = addImpl' False [] [] -- TODO: in patterns, don't add implicits to function names guarded by constructors -- and *not* inside a PHidden -addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm-addImpl' inpat env infns ist ptm+addImpl' :: Bool -> [Name] -> [Name] -> [Name] -> IState -> PTerm -> PTerm+addImpl' inpat env infns imp_meths ist ptm = mkUniqueNames env (ai False (zip env (repeat Nothing)) [] ptm) where 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 ist fc f ds []+ | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat qq imp_meths ist fc f ds [] ai qq env ds (PHidden (PRef fc f))- | not (f `elem` map fst env) = PHidden (handleErr $ aiFn inpat False qq ist fc f ds [])+ | 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@@ -1493,7 +1538,7 @@ | f `elem` infns = ai qq env ds (PApp fc (PInferRef fc f) as) | not (f `elem` map fst env) = let as' = map (fmap (ai qq env ds)) as in- handleErr $ aiFn inpat False qq ist fc f ds as'+ handleErr $ aiFn inpat False qq imp_meths ist fc f ds as' | Just (Just ty) <- lookup f env = let as' = map (fmap (ai qq env ds)) as arity = getPArity ty in@@ -1518,7 +1563,7 @@ PLam fc n ty' sc' _ -> ai qq env ds (PLam fc (sMN 0 "lamp") ty (PCase fc (PRef fc (sMN 0 "lamp") )- [(PRef fc n, sc)])) + [(PRef fc n, sc)])) ai qq env ds (PLet fc n ty val sc) = case lookupDef n (tt_ctxt ist) of [] -> let ty' = ai qq env ds ty@@ -1528,7 +1573,9 @@ _ -> ai qq env ds (PCase fc val [(PRef fc n, sc)]) ai qq env ds (PPi p n ty sc) = let ty' = ai qq env ds ty- sc' = ai qq ((n, Just ty):env) ds sc in+ 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' ai qq env ds (PGoal fc r n sc) = let r' = ai qq env ds r@@ -1543,6 +1590,7 @@ 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 tm = tm handleErr (Left err) = PElabError err@@ -1551,8 +1599,8 @@ -- if in a pattern, and there are no arguments, and there's no possible -- names with zero explicit arguments, don't add implicits. -aiFn :: Bool -> Bool -> Bool -> IState -> FC -> Name -> [[T.Text]] -> [PArg] -> Either Err PTerm-aiFn inpat True qq ist fc f ds []+aiFn :: Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -> [[T.Text]] -> [PArg] -> Either Err PTerm+aiFn inpat True qq imp_meths ist fc f ds [] = case lookupDef f (tt_ctxt ist) of [] -> Right $ PPatvar fc f alts -> let ialts = lookupCtxtName f (idris_implicits ist) in@@ -1560,7 +1608,7 @@ if (not (vname f) || tcname f || any (conCaf (tt_ctxt ist)) ialts) -- any constructor alts || any allImp ialts))- then aiFn inpat False qq ist fc f ds [] -- use it as a constructor+ then aiFn inpat False qq imp_meths ist fc f ds [] -- use it as a constructor else Right $ PPatvar fc f where imp (PExp _ _ _ _) = False imp _ = True@@ -1574,9 +1622,9 @@ vname (UN n) = True -- non qualified vname _ = False -aiFn inpat expat qq ist fc f ds as+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 ist fc f ds as+aiFn inpat expat qq imp_meths ist fc f 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@@ -1584,15 +1632,20 @@ [] -> nh x -> x case ns' of- [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as)+ [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc (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 alts -> Right $ PAlternative True $- map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f')+ map (\(f', ns) -> mkPApp fc (length ns) (PRef fc (isImpName f f')) (insertImpl ns as)) alts where+ -- if the name is in imp_meths, we should actually refer to the bound+ -- name rather than the global one after expanding implicits+ isImpName f f' | f `elem` imp_meths = f+ | otherwise = f'+ trimAlts [] alts = alts trimAlts ns alts = filter (\(x, _) -> any (\d -> d `isPrefixOf` nspace x) ns) alts@@ -1632,11 +1685,11 @@ case find n imps [] of Just (tm, imps') -> PImp p False l n tm : insImpAcc (M.insert n tm pnas) ps given imps'- Nothing ->- PImp p True l n Placeholder :- insImpAcc (M.insert n Placeholder pnas) ps given imps+ Nothing -> let ph = if f `elem` imp_meths then PRef fc n else Placeholder in+ PImp p True l n ph :+ insImpAcc (M.insert n ph pnas) ps given imps insImpAcc pnas (PTacImplicit p l n sc' ty : ps) given imps =- let sc = addImpl ist (substMatches (M.toList pnas) sc') in+ let sc = addImpl imp_meths ist (substMatches (M.toList pnas) sc') in case find n imps [] of Just (tm, imps') -> PTacImplicit p l n sc tm :@@ -1689,6 +1742,10 @@ return (a' : as') slAlts ns [] = return [] sl (PPair fc p l r) = do l' <- sl l; r' <- sl r; return (PPair fc p l' r')+ sl (PDPair fc p l t r) = do l' <- sl l+ 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 args' <- mapM slA args return $ PApp fc fn args'@@ -1715,7 +1772,11 @@ | (Bind n (Pi _ t _) sc :_) <- lookupTy f (tt_ctxt i) = Placeholder su (PApp fc f@(PRef _ fn) args)- | isDConName fn ctxt + -- here we use canBeDConName because the impossible pattern+ -- check will not necessarily fully resolve constructor names,+ -- and these bare names will otherwise get in the way of+ -- impossbility checking.+ | canBeDConName fn ctxt = PApp fc f (fmap (fmap su) args) su (PApp fc f args) = PHidden (PApp fc f args)@@ -1882,11 +1943,11 @@ match (PHidden x) (PHidden y) | RightOK xs <- match x y = return xs -- to collect variables | otherwise = return [] -- Otherwise hidden things are unmatchable- match (PHidden x) y - | RightOK xs <- match x y = return xs + match (PHidden x) y+ | RightOK xs <- match x y = return xs | otherwise = return []- match x (PHidden y) - | RightOK xs <- match x y = return xs + match x (PHidden y)+ | RightOK xs <- match x y = return xs | otherwise = return [] match (PUnifyLog x) y = match' x y match x (PUnifyLog y) = match' x y@@ -1949,8 +2010,11 @@ 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)- sm (PPi p x t sc) | n /=x = PPi p 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 (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)@@ -2063,4 +2127,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 t = return t
src/Idris/AbsSyntaxTree.hs view
@@ -18,11 +18,15 @@ import System.Console.Haskeline import System.IO +import Control.Applicative ((<|>))+ import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Except+import qualified Control.Monad.Trans.Class as Trans (lift) import Data.Data (Data) import Data.Function (on)+import Data.Generics.Uniplate.Data (universe) import Data.List hiding (group) import Data.Char import qualified Data.Map.Strict as M@@ -53,7 +57,7 @@ liftname :: Name -> Name, namespace :: Maybe [String], elabFC :: Maybe FC,- rec_elabDecl :: ElabWhat -> ElabInfo -> PDecl -> + rec_elabDecl :: ElabWhat -> ElabInfo -> PDecl -> Idris () } toplevel :: ElabInfo@@ -62,27 +66,27 @@ eInfoNames :: ElabInfo -> [Name] eInfoNames info = map fst (params info) ++ M.keys (inblock info) -data IOption = IOption { opt_logLevel :: Int,- opt_typecase :: Bool,- opt_typeintype :: Bool,- opt_coverage :: Bool,- opt_showimp :: Bool, -- ^^ show implicits- opt_errContext :: Bool,- opt_repl :: Bool,- opt_verbose :: Bool,- opt_nobanner :: Bool,- opt_quiet :: Bool,- opt_codegen :: Codegen,- opt_outputTy :: OutputType,- opt_ibcsubdir :: FilePath,- opt_importdirs :: [FilePath],- opt_triple :: String,- opt_cpu :: String,- opt_cmdline :: [Opt], -- remember whole command line- opt_origerr :: Bool,- opt_autoSolve :: Bool, -- ^ automatically apply "solve" tactic in prover- opt_autoImport :: [FilePath], -- ^ e.g. Builtins+Prelude- opt_optimise :: [Optimisation]+data IOption = IOption { opt_logLevel :: Int,+ opt_typecase :: Bool,+ opt_typeintype :: Bool,+ opt_coverage :: Bool,+ opt_showimp :: Bool, -- ^^ show implicits+ opt_errContext :: Bool,+ opt_repl :: Bool,+ opt_verbose :: Bool,+ opt_nobanner :: Bool,+ opt_quiet :: Bool,+ opt_codegen :: Codegen,+ opt_outputTy :: OutputType,+ opt_ibcsubdir :: FilePath,+ opt_importdirs :: [FilePath],+ opt_triple :: String,+ opt_cpu :: String,+ opt_cmdline :: [Opt], -- remember whole command line+ opt_origerr :: Bool,+ opt_autoSolve :: Bool, -- ^ automatically apply "solve" tactic in prover+ opt_autoImport :: [FilePath], -- ^ e.g. Builtins+Prelude+ opt_optimise :: [Optimisation] } deriving (Show, Eq) @@ -140,14 +144,16 @@ -- | The output mode in use data OutputMode = RawOutput Handle -- ^ Print user output directly to the handle- | IdeSlave Integer Handle -- ^ Send IDE output for some request ID to the handle+ | IdeMode Integer Handle -- ^ Send IDE output for some request ID to the handle deriving Show -- | How wide is the console? data ConsoleWidth = InfinitelyWide -- ^ Have pretty-printer assume that lines should not be broken | ColsWide Int -- ^ Manually specified - must be positive | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise+ deriving (Show, Eq) + -- | The global state used in the Idris monad data IState = IState { tt_ctxt :: Context, -- ^ All the currently defined names and their terms@@ -180,7 +186,11 @@ idris_name :: Int, idris_lineapps :: [((FilePath, Int), PTerm)], -- ^ Full application LHS on source line- idris_metavars :: [(Name, (Maybe Name, Int, Bool))], -- ^ The currently defined but not proven metavariables+ idris_metavars :: [(Name, (Maybe Name, Int, Bool))],+ -- ^ The currently defined but not proven metavariables. The Int+ -- is the number of vars to display as a context, the Maybe Name+ -- is its top-level function, and the Bool is whether :p is+ -- allowed idris_coercions :: [Name], idris_errRev :: [(Term, Term)], syntax_rules :: SyntaxRules,@@ -216,11 +226,13 @@ module_aliases :: M.Map [T.Text] [T.Text], idris_consolewidth :: ConsoleWidth, -- ^ How many chars wide is the console? idris_postulates :: S.Set Name,+ 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]), idris_repl_defs :: [Name], -- ^ List of names that were defined in the repl, and can be re-/un-defined elab_stack :: [Name], -- ^ Stack of names currently being elaborated- idris_symbols :: M.Map Name Name -- ^ Symbol table (preserves sharing of names)+ idris_symbols :: M.Map Name Name, -- ^ Symbol table (preserves sharing of names)+ idris_exports :: [Name] -- ^ Functions with ExportList } -- Required for parsers library, and therefore trifecta@@ -291,6 +303,8 @@ | IBCTotCheckErr FC String | IBCParsedRegion FC | IBCModDocs Name -- ^ The name is the special name used to track module docs+ | IBCUsage (Name, Int)+ | IBCExport Name deriving Show -- | The initial state for the compiler@@ -303,13 +317,19 @@ [] [] [] 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 [] Nothing Nothing [] [] M.empty [] -- | The monad for the main REPL - reading and processing files and updating -- global state (hence the IO inner monad). --type Idris = WriterT [Either String (IO ())] (State IState a)) type Idris = StateT IState (ExceptT Err IO) +catchError :: Idris a -> (Err -> Idris a) -> Idris a+catchError = liftCatch catchE++throwError :: Err -> Idris a+throwError = Trans.lift . throwE+ -- Commands in the REPL data Codegen = Via String@@ -324,6 +344,8 @@ deriving instance NFData Codegen !-} +data HowMuchDocs = FullDocs | OverviewDocs+ -- | REPL commands data Command = Quit | Help@@ -331,7 +353,8 @@ | NewDefn [PDecl] -- ^ Each 'PDecl' should be either a type declaration (at most one) or a clause defining the same name. | Undefine [Name] | Check PTerm- | DocStr (Either Name Const)+ | Core PTerm+ | DocStr (Either Name Const) HowMuchDocs | TotCheck Name | Reload | Load FilePath (Maybe Int) -- up to maximum line number@@ -393,8 +416,8 @@ | Quiet | NoBanner | ColourREPL Bool- | Ideslave- | IdeslaveSocket+ | Idemode+ | IdemodeSocket | ShowLibs | ShowLibdir | ShowIncs@@ -405,6 +428,7 @@ | NoREPL | OLogging Int | Output String+ | Interface | TypeCase | TypeInType | DefaultTotal@@ -445,6 +469,7 @@ | ShowOrigErr | AutoWidth -- ^ Automatically adjust terminal width | AutoSolve -- ^ Automatically issue "solve" tactic in interactive prover+ | UseConsoleWidth ConsoleWidth deriving (Show, Eq) -- Parsed declarations@@ -581,22 +606,28 @@ Name [(Name, t)] -- parameters [(Name, Docstring (Either Err PTerm))] -- parameter docstrings+ [Name] -- determining parameters [PDecl' t] -- declarations -- ^ Type class: arguments are documentation, syntax info, source location, constraints, -- class name, parameters, method declarations- | PInstance SyntaxInfo FC [(Name, t)] -- constraints- Name -- class- [t] -- parameters- t -- full instance type- (Maybe Name) -- explicit name- [PDecl' t]- -- ^ Instance declaration: arguments are syntax info, source location, constraints,- -- class name, parameters, full instance type, optional explicit name, and definitions+ | PInstance+ (Docstring (Either Err PTerm)) -- Instance docs+ [(Name, Docstring (Either Err PTerm))] -- Parameter docs+ SyntaxInfo+ FC [(Name, t)] -- constraints+ Name -- class+ [t] -- parameters+ t -- full instance type+ (Maybe Name) -- explicit name+ [PDecl' t]+ -- ^ Instance declaration: arguments are documentation, syntax info, source+ -- location, constraints, class name, parameters, full instance+ -- type, optional explicit name, and definitions | 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.- | PProvider SyntaxInfo FC (ProvideWhat' t) Name -- ^ Type provider. The first t is the type, the second is the term+ | 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 deriving Functor@@ -608,10 +639,12 @@ -- For elaborator state data EState = EState { case_decls :: [PDecl],- delayed_elab :: [Elab' EState ()]+ delayed_elab :: [Elab' EState ()],+ new_tyDecls :: [(Name, FC, [PArg], Type)] } -initEState = EState [] []+initEState :: EState+initEState = EState [] [] [] type ElabD a = Elab' EState a @@ -625,10 +658,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 [PDecl' t]- | PClauseR FC [t] t [PDecl' t]- | PWithR FC [t] t [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] deriving Functor {-! deriving instance Binary PClause'@@ -670,8 +703,8 @@ 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 (PClass _ _ _ _ n _ _ _ ms) = n : concatMap declared ms+declared (PInstance _ _ _ _ _ _ _ _ _ _) = [] declared (PDSL n _) = [n] declared (PSyntax _ _) = [] declared (PMutual _ ds) = concatMap declared ds@@ -689,8 +722,8 @@ 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 (PClass _ _ _ _ n _ _ _ ms) = concatMap tldeclared ms+tldeclared (PInstance _ _ _ _ _ _ _ _ _ _) = [] tldeclared _ = [] defined :: PDecl -> [Name]@@ -705,8 +738,8 @@ 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 (PClass _ _ _ _ n _ _ _ ms) = n : concatMap defined ms+defined (PInstance _ _ _ _ _ _ _ _ _ _) = [] defined (PDSL n _) = [n] defined (PSyntax _ _) = [] defined (PMutual _ ds) = concatMap defined ds@@ -746,6 +779,7 @@ | PLet FC Name PTerm PTerm PTerm -- ^ A let binding | PTyped PTerm PTerm -- ^ Term with explicit type | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x+ | 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 | PCase FC PTerm [(PTerm, PTerm)] -- ^ A case expression. Args are source location, scrutinee, and a list of pattern/RHS pairs@@ -760,7 +794,7 @@ | PAlternative Bool [PTerm] -- ^ True if only one may work. (| A, B, C|) | PHidden PTerm -- ^ Irrelevant or hidden pattern | PType -- ^ 'Type' type- | PUniverse Universe -- ^ Some universe + | PUniverse Universe -- ^ Some universe | PGoal FC PTerm Name PTerm -- ^ quoteGoal, used for %reflection functions | PConstant Const -- ^ Builtin types | Placeholder -- ^ Underscore@@ -777,7 +811,8 @@ | PUnifyLog PTerm -- ^ dump a trace of unifications when building term | PNoImplicits PTerm -- ^ never run implicit converions on the term | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term])- | PUnquote PTerm -- ^ ,Term+ | PUnquote PTerm -- ^ ~Term+ | PRunTactics FC PTerm -- ^ %runTactics tm - New-style proof script deriving (Eq, Data, Typeable) @@ -817,6 +852,8 @@ | Induction t | CaseTac t | Equiv t+ | Claim Name t+ | Unfocus | MatchRefine Name | LetTac Name t | LetTacTy Name t t | Exact t | Compute | Trivial | TCInstance@@ -938,6 +975,63 @@ type PArg = PArg' PTerm +-- | Get the highest FC in a term, if one exists+highestFC :: PTerm -> Maybe FC+highestFC (PQuote _) = Nothing+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 (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 (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+highestFC (PAs fc _ _) = Just fc+highestFC (PAlternative _ args) =+ case mapMaybe highestFC args of+ [] -> Nothing+ (fc:_) -> Just fc+highestFC (PHidden _) = Nothing+highestFC PType = Nothing+highestFC (PUniverse _) = Nothing+highestFC (PGoal fc _ _ _) = Just fc+highestFC (PConstant _) = Nothing+highestFC Placeholder = Nothing+highestFC (PDoBlock lines) =+ case map getDoFC lines of+ [] -> Nothing+ (fc:_) -> Just fc+ where+ getDoFC (DoExp fc t) = fc+ getDoFC (DoBind fc nm t) = fc+ getDoFC (DoBindP fc l r alts) = fc+ getDoFC (DoLet fc nm l r) = fc+ getDoFC (DoLetP fc l r) = fc++highestFC (PIdiom fc _) = Just fc+highestFC (PReturn fc) = Just fc+highestFC (PMetavar _) = Nothing+highestFC (PProof _) = Nothing+highestFC (PTactics _) = Nothing+highestFC (PElabError _) = Nothing+highestFC PImpossible = Nothing+highestFC (PCoerced tm) = highestFC tm+highestFC (PDisamb _ opts) = highestFC opts+highestFC (PUnifyLog tm) = highestFC tm+highestFC (PNoImplicits tm) = highestFC tm+highestFC (PQuasiquote _ _) = Nothing+highestFC (PUnquote tm) = highestFC tm+ -- Type class data data ClassInfo = CI { instanceName :: Name,@@ -945,7 +1039,8 @@ class_defaults :: [(Name, (Name, PDecl))], -- method name -> default impl class_default_superclasses :: [PDecl], class_params :: [Name],- class_instances :: [Name] }+ class_instances :: [Name],+ class_determiners :: [Int] } deriving Show {-! deriving instance Binary ClassInfo@@ -1035,8 +1130,8 @@ | Expr Name | SimpleExpr Name deriving (Show, Eq)- + {-! deriving instance Binary SSymbol deriving instance NFData SSymbol@@ -1084,7 +1179,7 @@ initDSL = DSL (PRef f (sUN ">>=")) (PRef f (sUN "return"))- (PRef f (sUN "<$>"))+ (PRef f (sUN "<*>")) (PRef f (sUN "pure")) Nothing Nothing@@ -1106,6 +1201,9 @@ syn_params :: [(Name, PTerm)], syn_namespace :: [String], no_imp :: [Name],+ imp_methods :: [Name], -- class methods. When expanding+ -- implicits, these should be expanded even under+ -- binders decoration :: Name -> Name, inPattern :: Bool, implicitAllowed :: Bool,@@ -1119,7 +1217,7 @@ deriving instance Binary SyntaxInfo !-} -defaultSyntax = Syn [] [] [] [] id False False Nothing 0 initDSL 0+defaultSyntax = Syn [] [] [] [] [] id False False Nothing 0 initDSL 0 expandNS :: SyntaxInfo -> Name -> Name expandNS syn n@(NS _ _) = n@@ -1174,6 +1272,9 @@ pairTy = sNS (sUN "Pair") ["Builtins"] pairCon = sNS (sUN "MkPair") ["Builtins"] +upairTy = sNS (sUN "UPair") ["Builtins"]+upairCon = sNS (sUN "MkUPair") ["Builtins"]+ eqTy = sUN "=" eqCon = sUN "Refl" eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $@@ -1307,6 +1408,7 @@ where startPrec = 0 funcAppPrec = 10+ prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation prettySe p bnd (PQuote r) = text "![" <> pretty r <> text "]"@@ -1369,7 +1471,7 @@ [x] -> group (opName True <$> group (prettySe startPrec bnd (getTm x))) [l,r] -> let precedence = maybe (startPrec - 1) prec f in bracket p precedence $ inFix (getTm l) (getTm r)- (l@(PExp _ _ _ _) : r@(PExp _ _ _ _) : rest) -> + (l@(PExp _ _ _ _) : r@(PExp _ _ _ _) : rest) -> bracket p funcAppPrec $ enclose lparen rparen (inFix (getTm l) (getTm r)) <+> align (group (vsep (map (prettyArgS bnd) rest)))@@ -1385,7 +1487,7 @@ Just (Infixr p') -> p' Just f' -> prec f' + 1 inFix l r = align . group $- (prettySe left bnd l <+> opName False) <$> + (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,@@ -1404,7 +1506,7 @@ align $ kwd "case" <+> prettySe startPrec bnd scr <+> kwd "of" <$> indent 2 (vsep (map ppcase cases)) where- ppcase (l, r) = let prettyCase = prettySe startPrec + ppcase (l, r) = let prettyCase = prettySe startPrec ([(n, False) | n <- vars l] ++ bnd) in nest nestingSize $ prettyCase l <+> text "=>" <+> prettyCase r@@ -1475,7 +1577,7 @@ 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 (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u) + 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)) -- XXX: add pretty for tactics prettySe p bnd (PProof ts) =@@ -1572,12 +1674,16 @@ getFixity :: String -> Maybe Fixity getFixity = flip M.lookup fixities --- | Pretty-printer helper for the binding site of a name-bindingOf :: Name -- ^^ the bound name- -> Bool -- ^^ whether the name is implicit- -> Doc OutputAnnotation-bindingOf n imp = annotate (AnnBoundName n imp) (text (show n))+-- | Determine whether a name was the one inserted for a hole or+-- guess by the delaborator+isHoleName :: Name -> Bool+isHoleName (UN n) = n == T.pack "[__]"+isHoleName _ = False +-- | Check whether a PTerm has been delaborated from a Term containing a Hole or Guess+containsHole :: PTerm -> Bool+containsHole pterm = or [isHoleName n | PRef _ n <- take 1000 $ universe pterm]+ -- | Pretty-printer helper for names that attaches the correct annotations prettyName :: Bool -- ^^ whether the name should be parenthesised if it is an infix operator@@ -1587,7 +1693,7 @@ -> Doc OutputAnnotation prettyName infixParen showNS bnd n | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_"- | (UN n') <- n, isPrefixOf "_" $ T.unpack n' = text "_"+ | (UN n') <- n, T.unpack n' == "_" = text "_" | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName | otherwise = annotate (AnnName n Nothing Nothing Nothing) fullName where fullName = text nameSpace <> parenthesise (text (baseName n))@@ -1611,7 +1717,7 @@ where showWs [] = empty showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs-showCImp ppo (PWith _ n l ws r w)+showCImp ppo (PWith _ n l ws r pn w) = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r <+> braces (text (show w)) where@@ -1635,9 +1741,9 @@ 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 _ (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@@ -1659,6 +1765,8 @@ getShowArgs [] = [] getShowArgs (e@(PExp _ _ _ tm) : xs) = e : getShowArgs xs getShowArgs (e : xs) | AlwaysShow `elem` argopts e = e : getShowArgs xs+ | PImp _ _ _ _ tm <- e+ , containsHole tm = e : getShowArgs xs getShowArgs (_ : xs) = getShowArgs xs getConsts :: [PArg] -> [PTerm]@@ -1811,16 +1919,16 @@ implicitNamesIn uvars ist tm = nub $ ni [] tm where ni env (PRef _ n)- | not (n `elem` env) + | not (n `elem` env) = case lookupTy n (tt_ctxt ist) of [] -> [n] _ -> if n `elem` uvars then [n] else []- ni env (PApp _ f@(PRef _ n) as) + ni env (PApp _ f@(PRef _ n) as) | n `elem` uvars = ni env f ++ concatMap (ni env) (map getTm as) | otherwise = concatMap (ni env) (map getTm as) 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 ++ + ni env (PCase _ c os) = ni env c ++ -- 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)))@@ -1850,7 +1958,7 @@ _ -> if n `elem` (map fst uvars) then [n] else [] 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 ++ + ni env (PCase _ c os) = ni env c ++ -- 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)))@@ -1909,4 +2017,3 @@ case lookupCtxtExact n (idris_optimisation ist) of Just (Optimise inacc detagg) -> map fst inacc Nothing -> []-
src/Idris/CmdOptions.hs view
@@ -11,6 +11,12 @@ import Data.Char import Data.Maybe +import Text.ParserCombinators.ReadP hiding (many, option)++import Safe (lastMay)+++ import qualified Text.PrettyPrint.ANSI.Leijen as PP runArgParser :: IO [Opt]@@ -26,7 +32,7 @@ idrisProgDesc = PP.vsep [PP.empty, PP.text "Idris is a general purpose pure functional programming language with dependent", PP.text "types. Dependent types allow types to be predicated on values, meaning that",- PP.text "some aspects of a program’s behaviour can be specified precisely in the type.",+ PP.text "some aspects of a program's behaviour can be specified precisely in the type.", PP.text "It is compiled, with eager evaluation. Its features are influenced by Haskell", PP.text "and ML.", PP.empty,@@ -67,12 +73,15 @@ files <- asA (many $ argument (fmap Filename str) (metavar "FILES")) -< () A parseVersion >>> A helper -< (flags ++ files) + parseFlags :: Parser [Opt] parseFlags = many $ flag' NoBanner (long "nobanner" <> help "Suppress the banner") <|> flag' Quiet (short 'q' <> long "quiet" <> help "Quiet verbosity")- <|> flag' Ideslave (long "ideslave")- <|> flag' IdeslaveSocket (long "ideslave-socket")+ <|> flag' Idemode (long "ide-mode" <> help "Run the Idris REPL with machine-readable syntax")+ <|> flag' IdemodeSocket (long "ide-mode-socket" <> help "Choose a socket for IDE mode to listen on")+ <|> flag' Idemode (long "ideslave" <> help "Deprecated version of --ide-mode") -- TODO: Remove in v0.9.18+ <|> flag' IdemodeSocket (long "ideslave-socket" <> help "Deprecated version of --ide-mode-socket") -- TODO: Remove in v0.9.18 <|> (Client <$> strOption (long "client")) <|> (OLogging <$> option auto (long "log" <> metavar "LEVEL" <> help "Debugging log level")) <|> flag' NoBasePkgs (long "nobasepkgs" <> help "Do not use the given base package")@@ -81,6 +90,7 @@ <|> flag' NoREPL (long "check" <> help "Typecheck only, don't start the REPL") <|> (Output <$> strOption (short 'o' <> long "output" <> metavar "FILE" <> help "Specify output file")) -- <|> flag' TypeCase (long "typecase")+ <|> flag' Interface (long "interface" <> help "Generate interface files from ExportLists") <|> flag' TypeInType (long "typeintype") <|> flag' DefaultTotal (long "total" <> help "Require functions to be total by default") <|> flag' DefaultPartial (long "partial")@@ -129,6 +139,10 @@ <|> (TargetCPU <$> strOption (long "cpu" <> metavar "CPU" <> help "Select target CPU e.g. corei7 or cortex-m3 (for LLVM codegen)")) <|> flag' (ColourREPL True) (long "colour" <> long "color" <> help "Force coloured output") <|> flag' (ColourREPL False) (long "nocolour" <> long "nocolor" <> help "Disable coloured output")++ <|> (UseConsoleWidth <$> option (str >>= parseConsoleWidth) (long "consolewidth" <> metavar "WIDTH" <> help "Select console width: auto, infinite, nat"))++ where getExt s = case maybeRead s of Just ext -> ext@@ -148,3 +162,22 @@ parseCodegen :: String -> Codegen parseCodegen "bytecode" = Bytecode parseCodegen cg = Via (map toLower cg)+++++parseConsoleWidth :: Monad m => String -> m ConsoleWidth+parseConsoleWidth "auto" = return AutomaticWidth+parseConsoleWidth "infinite" = return InfinitelyWide+parseConsoleWidth s =+ case lastMay (readP_to_S (integerReader) s) of+ Just (r, _) -> return $ ColsWide r+ _ -> fail $ "Cannot parse: " ++ s++++integerReader :: ReadP Int+integerReader = do+ digits <- many1 $ satisfy isDigit + return $ read digits+
src/Idris/Core/Binary.hs view
@@ -23,6 +23,26 @@ 3 -> fmap SubReport get _ -> error "Corrupted binary data for ErrorReportPart" +instance Binary Provenance where+ put ExpectedType = putWord8 0+ put (SourceTerm t) = do putWord8 1+ put t+ put InferredVal = putWord8 2+ put GivenVal = putWord8 3+ put (TooManyArgs t) = do putWord8 4+ put t++ get = do i <- getWord8+ case i of+ 0 -> return ExpectedType+ 1 -> do x1 <- get+ return (SourceTerm x1)+ 2 -> return InferredVal+ 3 -> return GivenVal+ 4 -> do x1 <- get+ return (TooManyArgs x1)+ _ -> error "Corrupted binary data for Provenance"+ instance Binary a => Binary (Err' a) where put (Msg str) = do putWord8 0 put str@@ -71,8 +91,8 @@ put x put y put z- put (CantResolve t) = do putWord8 15- put t+ put (CantResolve _ t) = do putWord8 15+ put t put (CantResolveAlts ns) = do putWord8 16 put ns put (IncompleteTerm t) = do putWord8 17@@ -122,6 +142,16 @@ 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 (NoEliminator s t) = do putWord8 37+ put s+ put t+ put (InvalidTCArg n t) = do putWord8 38+ put n+ put t get = do i <- getWord8 case i of@@ -148,7 +178,7 @@ 13 -> fmap NoTypeDecl get 14 -> do x <- get ; y <- get ; z <- get return $ NotInjective x y z- 15 -> fmap CantResolve get+ 15 -> fmap (CantResolve False) get 16 -> fmap CantResolveAlts get 17 -> fmap IncompleteTerm get 18 -> return UniverseError@@ -177,6 +207,16 @@ return $ ReflectionFailed x y 34 -> fmap WithFnType get 35 -> fmap CantMatch get+ 36 -> do x1 <- get+ x2 <- get+ x3 <- get+ return (ElabDebug x1 x2 x3)+ 37 -> do x1 <- get+ x2 <- get+ return (NoEliminator x1 x2)+ 38 -> do x1 <- get+ x2 <- get+ return (InvalidTCArg x1 x2) _ -> error "Corrupted binary data for Err'" ----- Generated by 'derive' @@ -317,6 +357,8 @@ BufferType -> putWord8 25 ManagedPtrType -> putWord8 26 VoidType -> putWord8 27+ WorldType -> putWord8 28+ TheWorld -> putWord8 29 get = do i <- getWord8 case i of@@ -360,6 +402,8 @@ 25 -> return BufferType 26 -> return ManagedPtrType 27 -> return VoidType+ 28 -> return WorldType+ 29 -> return TheWorld _ -> error "Corrupted binary data for Const"
src/Idris/Core/Constraints.hs view
@@ -8,6 +8,7 @@ import Control.Arrow import Control.Monad.RWS import Control.Monad.State+import qualified Data.Set as S import Data.List import Data.Maybe import qualified Data.Map.Strict as M@@ -19,7 +20,7 @@ ucheck cs = acyclic rels (map fst (M.toList rels)) where lhs (ULT l _) = l lhs (ULE l _) = l- cs' = nub cs+ cs' = S.toList (S.fromList cs) rels = mkRels cs' M.empty type Relations = M.Map UExp [(UConstraint, FC)]
src/Idris/Core/DeepSeq.hs view
@@ -43,6 +43,13 @@ instance NFData FC where rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () +instance NFData Provenance where+ rnf ExpectedType = ()+ rnf InferredVal = ()+ rnf GivenVal = ()+ rnf (SourceTerm x1) = rnf x1 `seq` ()+ rnf (TooManyArgs x1) = rnf x1 `seq` ()+ instance NFData Err where rnf (Msg x1) = rnf x1 `seq` () rnf (InternalMsg x1) = rnf x1 `seq` ()@@ -73,9 +80,11 @@ rnf (NoTypeDecl x1) = rnf x1 `seq` () rnf (NotInjective x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()- rnf (CantResolve x1) = rnf x1 `seq` ()+ rnf (CantResolve x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (InvalidTCArg x1 x2) = rnf x1 `seq` rnf x2 `seq` () 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 ProgramLineComment = () rnf (Inaccessible x1) = rnf x1 `seq` ()@@ -88,6 +97,7 @@ = 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` () instance NFData ImplicitInfo where rnf (Impl x1) = rnf x1 `seq` ()@@ -145,6 +155,8 @@ 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 = ()@@ -200,7 +212,7 @@ rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () instance NFData CaseInfo where- rnf (CaseInfo x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (CaseInfo x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () instance NFData CaseDefs where rnf (CaseDefs x1 x2 x3 x4)
src/Idris/Core/Elaborate.hs view
@@ -28,13 +28,6 @@ import Util.Pretty hiding (fill) --- I don't really want this here, but it's useful for the test shell-data Command = Theorem Name Raw- | Eval Raw- | Quit- | Print Name- | Tac (Elab ())- data ElabState aux = ES (ProofState, aux) String (Maybe (ElabState aux)) deriving Show @@ -173,30 +166,30 @@ -- Some handy gadgets for pulling out bits of state --- get the global context+-- | Get the global context get_context :: Elab' aux Context get_context = do ES p _ _ <- get return $! (context (fst p)) --- update the context+-- | Update the context. -- (should only be used for adding temporary definitions or all sorts of -- stuff could go wrong) set_context :: Context -> Elab' aux () set_context ctxt = do ES (p, a) logs prev <- get put (ES (p { context = ctxt }, a) logs prev) --- get the proof term+-- | get the proof term get_term :: Elab' aux Term get_term = do ES p _ _ <- get return $! (getProofTerm (pterm (fst p))) --- get the proof term+-- | modify the proof term update_term :: (Term -> Term) -> Elab' aux () update_term f = do ES (p,a) logs prev <- get let p' = p { pterm = mkProofTerm (f (getProofTerm (pterm p))) } put (ES (p', a) logs prev) --- get the local context at the currently in focus hole+-- | get the local context at the currently in focus hole get_env :: Elab' aux Env get_env = do ES p _ _ <- get lift $ envAtFocus (fst p)@@ -213,14 +206,14 @@ get_probs = do ES p _ _ <- get return $! (problems (fst p)) --- Return recently solved names (that is, the names solved since the+-- | Return recently solved names (that is, the names solved since the -- last call to get_recents) get_recents :: Elab' aux [Name] get_recents = do ES (p, a) l prev <- get put (ES (p { recents = [] }, a) l prev) return (recents p) --- get the current goal type+-- | get the current goal type goal :: Elab' aux Type goal = do ES p _ _ <- get b <- lift $ goalAtFocus (fst p)@@ -233,15 +226,15 @@ Guess _ _ -> return True _ -> return False --- Get the guess at the current hole, if there is one-get_guess :: Elab' aux Type+-- | Get the guess at the current hole, if there is one+get_guess :: Elab' aux Term get_guess = do ES p _ _ <- get b <- lift $ goalAtFocus (fst p) case b of Guess t v -> return $! v _ -> fail "Not a guess" --- typecheck locally+-- | Typecheck locally get_type :: Raw -> Elab' aux Type get_type tm = do ctxt <- get_context env <- get_env@@ -254,7 +247,7 @@ (val, ty) <- lift $ check ctxt env tm return $! (finalise val, finalise ty) --- get holes we've deferred for later definition+-- | get holes we've deferred for later definition get_deferred :: Elab' aux [Name] get_deferred = do ES p _ _ <- get return $! (deferred (fst p))@@ -271,17 +264,18 @@ isInj ctxt (Bind _ (Pi _ _ _) sc) = True isInj ctxt _ = False --- get instance argument names+-- | get instance argument names get_instances :: Elab' aux [Name] get_instances = do ES p _ _ <- get return $! (instances (fst p)) --- get auto argument names+-- | get auto argument names get_autos :: Elab' aux [(Name, [Name])] get_autos = do ES p _ _ <- get return $! (autos (fst p)) --- given a desired hole name, return a unique hole name+-- | given a desired hole name, return a unique hole name+unique_hole :: Name -> Elab' aux Name unique_hole = unique_hole' False unique_hole' :: Bool -> Name -> Elab' aux Name@@ -314,6 +308,12 @@ claim :: Name -> Raw -> Elab' aux () claim n t = processTactic' (Claim n t) +claimFn :: Name -> Name -> Raw -> Elab' aux ()+claimFn n bn t = processTactic' (ClaimFn n bn t)++unifyGoal :: Raw -> Elab' aux ()+unifyGoal t = processTactic' (UnifyGoal t)+ exact :: Raw -> Elab' aux () exact t = processTactic' (Exact t) @@ -667,8 +667,8 @@ solve focus f -simple_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux ()-simple_app fun arg appstr =+simple_app :: Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()+simple_app infer fun arg str = do a <- getNameFrom (sMN 0 "argTy") b <- getNameFrom (sMN 0 "retTy") f <- getNameFrom (sMN 0 "f")@@ -678,23 +678,29 @@ claim f (RBind (sMN 0 "aX") (Pi Nothing (Var a) RType) (Var b)) tm <- get_term start_unify s+ -- if 'infer' is set, we're assuming it's a simply typed application+ -- so safe to unify with the goal type (as there'll be no dependencies)+ when infer $ unifyGoal (Var b)+ hs <- get_holes claim s (Var a) prep_fill f [s] focus f; fun focus s; arg tm <- get_term ps <- get_probs- complete_fill+ ty <- goal hs <- get_holes+ complete_fill env <- get_env -- We don't need a and b in the hole queue any more since they were -- just for checking f, so move them to the end. If they never end up -- getting solved, we'll get an 'Incomplete term' error.+ hs <- get_holes when (a `elem` hs) $ do movelast a when (b `elem` hs) $ do movelast b end_unify- where regretWith err = try regret- (lift $ tfail err)+ where+ regretWith err = try regret (lift $ tfail err) -- Abstract over an argument of unknown type, giving a name for the hole -- which we'll fill with the argument type too.@@ -721,10 +727,11 @@ if (length ps' > length ps) then case reverse ps' of ((x, y, _, env, inerr, while, _) : _) ->- let env' = map (\(x, b) -> (x, binderTy b)) env in+ let (xp, yp) = getProvenance inerr+ env' = map (\(x, b) -> (x, binderTy b)) env in lift $ tfail $ case err of- Nothing -> CantUnify False x y inerr env' 0+ Nothing -> CantUnify False (x, xp) (y, yp) inerr env' 0 Just e -> e else return $! () @@ -749,20 +756,20 @@ try' :: Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a try' t1 t2 proofSearch- = do s <- get- ps <- get_probs- ulog <- getUnifyLog- case prunStateT 999999 False ps t1 s of- OK ((v, _, _), s') -> do put s'- return $! v- Error e1 -> traceWhen ulog ("try failed " ++ show e1) $- if recoverableErr e1 then- do case runStateT t2 s of- OK (v, s') -> do put s'; return $! v- Error e2 -> if score e1 >= score e2- then lift (tfail e1)- else lift (tfail e2)- else lift (tfail e1)+ = do s <- get+ ps <- get_probs+ ulog <- getUnifyLog+ case prunStateT 999999 False ps t1 s of+ OK ((v, _, _), s') -> do put s'+ return $! v+ Error e1 -> traceWhen ulog ("try failed " ++ show e1) $+ if recoverableErr e1 then+ do case runStateT t2 s of+ OK (v, s') -> do put s'; return $! v+ Error e2 -> if score e1 >= score e2+ then lift (tfail e1)+ else lift (tfail e2)+ else lift (tfail e1) where recoverableErr err@(CantUnify r x y _ _ _) = -- traceWhen r (show err) $ r || proofSearch@@ -772,8 +779,25 @@ recoverableErr (ProofSearchFail _) = False recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e recoverableErr (At _ e) = recoverableErr e+ recoverableErr (ElabDebug _ _ _) = False recoverableErr _ = True +tryCatch :: Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a+tryCatch t1 t2 + = do s <- get+ ps <- get_probs+ ulog <- getUnifyLog+ case prunStateT 999999 False ps t1 s of+ OK ((v, _, _), s') -> do put s'+ return $! v+ Error e1 -> traceWhen ulog ("tryCatch failed " ++ show e1) $+ case runStateT (t2 e1) s of+ OK (v, s') -> do put s'+ return $! v+ Error e2 -> if score e1 >= score e2+ then lift (tfail e1)+ else lift (tfail e2)+ tryWhen :: Bool -> Elab' aux a -> Elab' aux a -> Elab' aux a tryWhen True a b = try a b tryWhen False a b = a@@ -832,6 +856,19 @@ ((_,_,_,_,e,_,_):_) -> Error e else OK ((v, newpmax, problems p), s') Error e -> Error e++debugElaborator :: Maybe String -> Elab' aux a+debugElaborator msg = do ps <- fmap proof get+ saveState -- so we don't need to remember the hole order+ hs <- get_holes+ holeInfo <- mapM getHoleInfo hs+ loadState+ lift . Error $ ElabDebug msg (getProofTerm (pterm ps)) holeInfo+ where getHoleInfo :: Name -> Elab' aux (Name, Type, [(Name, Binder Type)])+ getHoleInfo h = do focus h+ g <- goal+ env <- get_env+ return (h, g, env) qshow :: Fails -> String qshow fs = show (map (\ (x, y, _, _, _, _, _) -> (x, y)) fs)
src/Idris/Core/Evaluate.hs view
@@ -9,9 +9,9 @@ addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl, addDatatype, addCasedef, simplifyCasedef, addOperator, lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact,- lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal,+ lookupP, lookupP_all, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal, mapDefCtxt,- lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, isTConName, isConName, isFnName,+ lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, canBeDConName, isTConName, isConName, isFnName, Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions, isUniverse) where @@ -208,9 +208,10 @@ -- returns 'True' if the function should block -- normal evaluation should return false- blockSimplify (CaseInfo inl dict) n stk+ blockSimplify (CaseInfo inl always dict) n stk | RunTT `elem` opts- = not (inl || dict) || elem n stk+ = if always then False+ else not (inl || dict) || elem n stk | Simplify `elem` opts = (not (inl || dict) || elem n stk) || (n == sUN "prim__syntactic_eq")@@ -679,7 +680,8 @@ } data CaseInfo = CaseInfo {- case_inlinable :: Bool,+ case_inlinable :: Bool, -- decided by machine+ case_alwaysinline :: Bool, -- decided by %inline flag tc_dictionary :: Bool } @@ -706,7 +708,7 @@ show (Function ty tm) = "Function: " ++ show (ty, tm) show (TyDecl nt ty) = "TyDecl: " ++ show nt ++ " " ++ show ty show (Operator ty _ _) = "Operator: " ++ show ty- show (CaseOp (CaseInfo inlc inlr) ty atys ps_in ps cd)+ show (CaseOp (CaseInfo inlc inla inlr) ty atys ps_in ps cd) = let (ns, sc) = cases_compiletime cd (ns_t, sc_t) = cases_totcheck cd (ns', sc') = cases_runtime cd in@@ -717,7 +719,8 @@ show ns ++ " " ++ show sc ++ "\n\n" ++ "RUN TIME:\n\n" ++ show ns' ++ " " ++ show sc' ++ "\n\n" ++- if inlc then "Inlinable\n" else "Not inlinable\n"+ if inlc then "Inlinable" else "Not inlinable" +++ if inla then " Aggressively\n" else "\n" ------- @@ -865,7 +868,7 @@ [([Name], Term, Term)] -> -- inlined [([Name], Term, Term)] -> -- run time Type -> Context -> Context-addCasedef n ei ci@(CaseInfo alwaysInline tcdict)+addCasedef n ei ci@(CaseInfo inline alwaysInline tcdict) tcase covering reflect asserted argtys inacc ps_in ps_tot ps_inl ps_ct ps_rt ty uctxt = let ctxt = definitions uctxt@@ -968,47 +971,55 @@ isTConName :: Name -> Context -> Bool isTConName n ctxt- = or $ do def <- lookupCtxt n (definitions ctxt)- case tfst def of- (TyDecl (TCon _ _) _) -> return True- _ -> return False+ = case lookupDefExact n ctxt of+ Just (TyDecl (TCon _ _) _) -> True+ _ -> False +-- | Check whether a resolved name is certainly a data constructor isDConName :: Name -> Context -> Bool isDConName n ctxt+ = case lookupDefExact n ctxt of+ Just (TyDecl (DCon _ _ _) _) -> True+ _ -> False++-- | Check whether any overloading of a name is a data constructor+canBeDConName :: Name -> Context -> Bool+canBeDConName n ctxt = or $ do def <- lookupCtxt n (definitions ctxt) case tfst def of- (TyDecl (DCon _ _ _) _) -> return True- _ -> return False+ (TyDecl (DCon _ _ _) _) -> return True+ _ -> return False isFnName :: Name -> Context -> Bool isFnName n ctxt- = let def = lookupCtxtExact n (definitions ctxt) in- case def of- Just (Function _ _, _, _, _) -> True- Just (Operator _ _ _, _, _, _) -> True- Just (CaseOp _ _ _ _ _ _, _, _, _) -> True- _ -> False+ = case lookupDefExact n ctxt of+ Just (Function _ _) -> True+ Just (Operator _ _ _) -> True+ Just (CaseOp _ _ _ _ _ _) -> True+ _ -> False isTCDict :: Name -> Context -> Bool isTCDict n ctxt- = let def = lookupCtxtExact n (definitions ctxt) in- case def of- Just (Function _ _, _, _, _) -> False- Just (Operator _ _ _, _, _, _) -> False- Just (CaseOp ci _ _ _ _ _, _, _, _) -> tc_dictionary ci- _ -> False+ = case lookupDefExact n ctxt of+ Just (Function _ _) -> False+ Just (Operator _ _ _) -> False+ Just (CaseOp ci _ _ _ _ _) -> tc_dictionary ci+ _ -> False lookupP :: Name -> Context -> [Term]-lookupP n ctxt+lookupP = lookupP_all False++lookupP_all :: Bool -> Name -> Context -> [Term]+lookupP_all all n ctxt = do def <- lookupCtxt n (definitions ctxt) p <- case def of- (Function ty tm, a, _, _) -> return (P Ref n ty, a)- (TyDecl nt ty, a, _, _) -> return (P nt n ty, a)+ (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)+ (Operator ty _ _, a, _, _) -> return (P Ref n ty, a) case snd p of- Hidden -> []- _ -> return (fst p)+ Hidden -> if all then return (fst p) else []+ _ -> return (fst p) lookupDefExact :: Name -> Context -> Maybe Def lookupDefExact n ctxt = tfst <$> lookupCtxtExact n (definitions ctxt)
src/Idris/Core/Execute.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE PatternGuards, ExistentialQuantification, CPP #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Core.Execute (execute) where import Idris.AbsSyntax import Idris.AbsSyntaxTree-import IRTS.Lang(FType(..))+import IRTS.Lang(FDesc(..), FType(..)) import Idris.Primitives(Prim(..), primitives) @@ -22,7 +23,7 @@ import Control.Exception import Control.Monad.Trans import Control.Monad.Trans.State.Strict-import Control.Monad.Except (ExceptT, runExceptT, throwError)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Control.Monad hiding (forM) import Data.Maybe import Data.Bits@@ -111,7 +112,8 @@ return $ normalise ctxt env' tm where toBinder (n, v) = do v' <- toTT v return (n, Let Erased v')-toTT (EHandle _) = return Erased+toTT (EHandle _) = execFail $ Msg "Can't convert handles back to TT after execution." +toTT (EPtr ptr) = execFail $ Msg "Can't convert pointers back to TT after execution." unApplyV :: ExecVal -> (ExecVal, [ExecVal]) unApplyV tm = ua [] tm@@ -138,7 +140,7 @@ putExecState = lift . put execFail :: Err -> Exec a-execFail = throwError+execFail = throwE execIO :: IO a -> Exec a execIO = lift . lift@@ -231,52 +233,85 @@ | fp == pioret = execApp env ctxt (mkEApp con [tp, v]) rest -- Special cases arising from not having access to the C RTS in the interpreter-execApp env ctxt (EP _ fp _) (_:fn:str:_:rest)- | fp == mkfprim,- Just (FFun "putStr" _ _) <- foreignFromTT fn- = case str of- EConstant (Str arg) -> do execIO (putStr arg)- execApp env ctxt ioUnit rest- _ -> execFail . Msg $- "The argument to putStr should be a constant string, but it was " ++- show str ++- ". Are all cases covered?"-execApp env ctxt (EP _ fp _) (_:fn:ch:_:rest)+execApp env ctxt f@(EP _ fp _) args@(xs:_:_:_:args') | fp == mkfprim,- Just (FFun "putchar" _ _) <- foreignFromTT fn+ (ty : fn : w : rest) <- reverse args' =+ execForeign env ctxt getArity ty fn rest (mkEApp f args)+ where getArity = case unEList xs of+ Just as -> length as+ _ -> 0++execApp env ctxt c@(EP (DCon _ arity _) n _) args =+ do let args' = take arity args+ let restArgs = drop arity args+ execApp env ctxt (mkEApp c args') restArgs++execApp env ctxt c@(EP (TCon _ arity) n _) args =+ do let args' = take arity args+ let restArgs = drop arity args+ execApp env ctxt (mkEApp c args') restArgs++execApp env ctxt f@(EP _ n _) args =+ do let val = lookupDef n ctxt+ case val of+ [Function _ tm] -> fail "should already have been eval'd"+ [TyDecl nt ty] -> return $ mkEApp f args+ [Operator tp arity op] ->+ if length args >= arity+ then 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)+ else return (mkEApp f args)+ [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun+ do rhs <- doExec env ctxt tm+ execApp env ctxt rhs args+ [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] ->+ do res <- execCase env ctxt ns sc args+ return $ fromMaybe (mkEApp f args) res+ thing -> return $ mkEApp f args+execApp env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg+ let (f', as) = unApplyV ret+ execApp env ctxt f' (as ++ args)+execApp env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp env ctxt f (args1 ++ args2)+execApp env ctxt f args = return (mkEApp f args)++execForeign env ctxt arity ty fn xs onfail+ | Just (FFun "putStr" [(_, str)] _) <- foreignFromTT arity ty fn xs+ = case str of+ EConstant (Str arg) -> do execIO (putStr arg)+ execApp env ctxt ioUnit (drop arity xs)+ _ -> execFail . Msg $+ "The argument to putStr should be a constant string, but it was " +++ show str +++ ". Are all cases covered?"+ | Just (FFun "putchar" [(_, ch)] _) <- foreignFromTT arity ty fn xs = case ch of EConstant (Ch c) -> do execIO (putChar c)- execApp env ctxt ioUnit rest+ execApp env ctxt ioUnit (drop arity xs) EConstant (I i) -> do execIO (putChar (toEnum i))- execApp env ctxt ioUnit rest+ execApp env ctxt ioUnit (drop arity xs) _ -> execFail . Msg $ "The argument to putchar should be a constant character, but it was " ++ show str ++ ". Are all cases covered?"-execApp env ctxt (EP _ fp _) (_:fn:_:handle:_:rest)- | fp == mkfprim,- Just (FFun "idris_readStr" _ _) <- foreignFromTT fn+ | Just (FFun "idris_readStr" [_, (_, handle)] _) <- foreignFromTT arity ty fn xs = case handle of EHandle h -> do contents <- execIO $ hGetLine h- execApp env ctxt (EConstant (Str (contents ++ "\n"))) rest+ execApp env ctxt (EConstant (Str (contents ++ "\n"))) (drop arity xs) _ -> execFail . Msg $ "The argument to idris_readStr should be a handle, but it was " ++ show handle ++ ". Are all cases covered?"-execApp env ctxt (EP _ fp _) (_:fn:_:rest)- | fp == mkfprim,- Just (FFun "getchar" _ _) <- foreignFromTT fn+ | Just (FFun "getchar" _ _) <- foreignFromTT arity ty fn xs = do -- The C API returns an Int which Idris library code -- converts; thus, we must make an int here. ch <- execIO $ fmap (ioWrap . EConstant . I . fromEnum) getChar- execApp env ctxt ch rest-execApp env ctxt (EP _ fp _) (_:fn:rest)- | fp == mkfprim,- Just (FFun "idris_time" _ _) <- foreignFromTT fn+ execApp env ctxt ch xs+ | Just (FFun "idris_time" _ _) <- foreignFromTT arity ty fn xs = do execIO $ fmap (ioWrap . EConstant . I . round) getPOSIXTime-execApp env ctxt (EP _ fp _) (_:fn:fileStr:modeStr:rest)- | fp == mkfprim,- Just (FFun "fileOpen" _ _) <- foreignFromTT fn+ | Just (FFun "fileOpen" [(_,fileStr), (_,modeStr)] _) <- foreignFromTT arity ty fn xs = case (fileStr, modeStr) of (EConstant (Str f), EConstant (Str mode)) -> do f <- execIO $@@ -291,10 +326,10 @@ case fmap (openFile f) m of Right h -> do h' <- h hSetBinaryMode h' True- return $ Right (ioWrap (EHandle h'), tail rest)+ return $ Right (ioWrap (EHandle h'), drop arity xs) Left err -> return $ Left err) (\e -> let _ = ( e::SomeException)- in return $ Right (ioWrap (EPtr nullPtr), tail rest))+ in return $ Right (ioWrap (EPtr nullPtr), drop arity xs)) case f of Left err -> execFail . Msg $ err Right (res, rest) -> execApp env ctxt res rest@@ -302,109 +337,80 @@ "The arguments to fileOpen should be constant strings, but they were " ++ show fileStr ++ " and " ++ show modeStr ++ ". Are all cases covered?"--execApp env ctxt (EP _ fp _) (_:fn:handle:rest)- | fp == mkfprim,- Just (FFun "fileEOF" _ _) <- foreignFromTT fn+ | Just (FFun "fileEOF" [(_,handle)] _) <- foreignFromTT arity ty fn xs = case handle of EHandle h -> do eofp <- execIO $ hIsEOF h let res = ioWrap (EConstant (I $ if eofp then 1 else 0))- execApp env ctxt res (tail rest)+ execApp env ctxt res (drop arity xs) _ -> execFail . Msg $ "The argument to fileEOF should be a file handle, but it was " ++ show handle ++ ". Are all cases covered?"--execApp env ctxt (EP _ fp _) (_:fn:handle:rest)- | fp == mkfprim,- Just (FFun "fileClose" _ _) <- foreignFromTT fn+ | Just (FFun "fileClose" [(_,handle)] _) <- foreignFromTT arity ty fn xs = case handle of EHandle h -> do execIO $ hClose h- execApp env ctxt ioUnit (tail rest)+ execApp env ctxt ioUnit (drop arity xs) _ -> execFail . Msg $ "The argument to fileClose should be a file handle, but it was " ++ show handle ++ ". Are all cases covered?" -execApp env ctxt (EP _ fp _) (_:fn:ptr:rest)- | fp == mkfprim,- Just (FFun "isNull" _ _) <- foreignFromTT fn+ | Just (FFun "isNull" [(_, ptr)] _) <- foreignFromTT arity ty fn xs = case ptr of EPtr p -> let res = ioWrap . EConstant . I $ if p == nullPtr then 1 else 0- in execApp env ctxt res (tail rest)+ in execApp env ctxt res (drop arity xs) -- Handles will be checked as null pointers sometimes - but if we got a -- real Handle, then it's valid, so just return 1. EHandle h -> let res = ioWrap . EConstant . I $ 0- in execApp env ctxt res (tail rest)+ in execApp env ctxt res (drop arity xs) -- A foreign-returned char* has to be tested for NULL sometimes EConstant (Str s) -> let res = ioWrap . EConstant . I $ 0- in execApp env ctxt res (tail rest)+ in execApp env ctxt res (drop arity xs) _ -> execFail . Msg $ "The argument to isNull should be a pointer or file handle or string, but it was " ++ show ptr ++ ". Are all cases covered?" - -- Right now, there's no way to send command-line arguments to the executor, -- so just return 0.-execApp env ctxt (EP _ fp _) (_:fn:rest)- | fp == mkfprim,- Just (FFun "idris_numArgs" _ _) <- foreignFromTT fn+execForeign env ctxt arity ty fn xs onfail + | Just (FFun "idris_numArgs" _ _) <- foreignFromTT arity ty fn xs = let res = ioWrap . EConstant . I $ 0- in execApp env ctxt res (tail rest)+ in execApp env ctxt res (drop arity xs) -execApp env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim- = case foreignFromTT fn of- Just (FFun f argTs retT) | length xs >= length argTs ->- do let (args', xs') = (take (length argTs) xs, -- foreign args- drop (length argTs + 1) xs) -- rest- res <- stepForeign (ty:fn:args')+execForeign env ctxt arity ty fn xs onfail+ = case foreignFromTT arity ty fn xs of+ Just ffun@(FFun f argTs retT) | length xs >= arity ->+ do let (args', xs') = (take arity xs, -- foreign args+ drop arity xs) -- rest+ res <- call ffun (map snd argTs) case res of Nothing -> fail $ "Could not call foreign function \"" ++ f ++- "\" with args " ++ show args+ "\" with args " ++ show (map snd argTs) Just r -> return (mkEApp r xs')- Nothing -> return (mkEApp f args)+ _ -> return onfail -execApp env ctxt c@(EP (DCon _ arity _) n _) args =- do let args' = take arity args- let restArgs = drop arity args- execApp env ctxt (mkEApp c args') restArgs -execApp env ctxt c@(EP (TCon _ arity) n _) args =- do let args' = take arity args- let restArgs = drop arity args- execApp env ctxt (mkEApp c args') restArgs+splitArg tm | (_, [_,_,l,r]) <- unApplyV tm -- pair, two implicits+ = Just (toFDesc l, r)+splitArg _ = Nothing -execApp env ctxt f@(EP _ n _) args =- do let val = lookupDef n ctxt- case val of- [Function _ tm] -> fail "should already have been eval'd"- [TyDecl nt ty] -> return $ mkEApp f args- [Operator tp arity op] ->- if length args >= arity- then 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)- else return (mkEApp f args)- [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun- do rhs <- doExec env ctxt tm- execApp env ctxt rhs args- [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] ->- do res <- execCase env ctxt ns sc args- return $ fromMaybe (mkEApp f args) res- thing -> return $ mkEApp f args-execApp env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg- let (f', as) = unApplyV ret- execApp env ctxt f' (as ++ args)-execApp env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp env ctxt f (args1 ++ args2)-execApp env ctxt f args = return (mkEApp f args)+toFDesc tm + | (EP _ n _, []) <- unApplyV tm = FCon (deNS n) + | (EP _ n _, as) <- unApplyV tm = FApp (deNS n) (map toFDesc as)+toFDesc _ = FUnknown +deNS (NS n _) = n+deNS n = n++prf = sUN "prim__readFile"+pwf = sUN "prim__writeFile" prs = sUN "prim__readString"+pws = sUN "prim__writeString" pbm = sUN "prim__believe_me"-pstd = sUN "prim__stdin"+pstdin = sUN "prim__stdin"+pstdout = sUN "prim__stdout" mkfprim = sUN "mkForeignPrim" pioret = sUN "prim_io_return" piobind = sUN "prim_io_bind"@@ -415,14 +421,33 @@ -- | Look up primitive operations in the global table and transform them into ExecVal functions getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal) getOp fn [_, _, x] | fn == pbm = Just (return x)-getOp fn [EP _ fn' _]- | fn == prs && fn' == pstd =+getOp fn [_, EConstant (Str n)]+ | fn == pws =+ Just $ do execIO $ putStr n+ return (EConstant (I 0))+getOp fn [_]+ | fn == prs = Just $ do line <- execIO getLine return (EConstant (Str line))-getOp fn [EHandle h]- | fn == prs =+getOp fn [_, EP _ fn' _, EConstant (Str n)]+ | fn == pwf && fn' == pstdout =+ Just $ do execIO $ putStr n+ return (EConstant (I 0))+getOp fn [_, EP _ fn' _]+ | fn == prf && fn' == pstdin =+ Just $ do line <- execIO getLine+ return (EConstant (Str line))+getOp fn [_, EHandle h, EConstant (Str n)]+ | fn == pwf =+ Just $ do execIO $ hPutStr h n+ return (EConstant (I 0))+getOp fn [_, EHandle h]+ | fn == prf = Just $ do contents <- execIO $ hGetLine h return (EConstant (Str (contents ++ "\n")))+getOp fn [_, arg]+ | 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) getPrim n [] = Nothing@@ -466,6 +491,7 @@ let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in execCase' env ctxt amap' newCase Nothing -> return Nothing+execCase' _ _ _ cse = fail $ "The impossible happened: tried to exec " ++ show cse chooseAlt :: ExecVal -> [CaseAlt] -> Maybe (SC, [(Name, ExecVal)]) chooseAlt tm (DefaultCase sc : alts) | ok tm = Just (sc, [])@@ -485,22 +511,35 @@ chooseAlt _ [] = Nothing ---idrisType :: FType -> ExecVal-idrisType FUnit = EP Ref unitTy EErased-idrisType ft = EConstant (idr ft)- where idr (FArith ty) = AType ty- idr FString = StrType- idr FPtr = PtrType+data Foreign = FFun String [(FDesc, ExecVal)] FDesc deriving Show -data Foreign = FFun String [FType] FType deriving Show+toFType :: FDesc -> FType+toFType (FCon c) + | c == sUN "C_Str" = FString+ | c == sUN "C_Float" = FArith ATFloat+ | c == sUN "C_Ptr" = FPtr+ | c == sUN "C_MPtr" = FManagedPtr+ | c == sUN "C_Unit" = FUnit+toFType (FApp c [_,ity]) + | c == sUN "C_IntT" = FArith (toAType ity)+ where toAType (FCon i) + | i == sUN "C_IntChar" = ATInt ITChar+ | i == sUN "C_IntNative" = ATInt ITNative+ | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)+ | i == sUN "C_IntBits16" = ATInt (ITFixed IT16)+ | i == sUN "C_IntBits32" = ATInt (ITFixed IT32)+ | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)+ toAType t = error (show t ++ " not defined in toAType") +toFType (FApp c [_]) + | c == sUN "C_Any" = FAny+toFType t = error (show t ++ " not defined in toFType") call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal) call (FFun name argTypes retType) args = do fn <- findForeign name- maybe (return Nothing) (\f -> Just . ioWrap <$> call' f args retType) fn+ maybe (return Nothing) + (\f -> Just . ioWrap <$> call' f args (toFType retType)) fn where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal call' (Fun _ h) args (FArith (ATInt ITNative)) = do res <- execIO $ callFFI h retCInt (prepArgs args)@@ -532,7 +571,7 @@ call' (Fun _ h) args FPtr = EPtr <$> (execIO $ callFFI h (retPtr retVoid) (prepArgs args)) call' (Fun _ h) args FUnit = do _ <- execIO $ callFFI h retVoid (prepArgs args) return $ EP Ref unitCon EErased-+ call' _ _ _ = fail "the impossible happened in call' in Execute.hs" prepArgs = map prepArg prepArg (EConstant (I i)) = argCInt (fromIntegral i)@@ -549,15 +588,11 @@ prepArg other = trace ("Could not use " ++ take 100 (show other) ++ " as FFI arg.") undefined --foreignFromTT :: ExecVal -> Maybe Foreign-foreignFromTT t = case (unApplyV t) of- (_, [(EConstant (Str name)), args, ret]) ->- do argTy <- unEList args- argFTy <- sequence $ map getFTy argTy- retFTy <- getFTy ret- return $ FFun name argFTy retFTy- _ -> trace ("failed to construct ffun") Nothing+foreignFromTT :: Int -> ExecVal -> ExecVal -> [ExecVal] -> Maybe Foreign+foreignFromTT arity ty (EConstant (Str name)) args+ = do argFTyVals <- mapM splitArg (take arity args)+ return $ FFun name argFTyVals (toFDesc ty)+foreignFromTT arity ty fn args = trace ("failed to construct ffun from " ++ show (ty,fn,args)) Nothing getFTy :: ExecVal -> Maybe FType getFTy (EApp (EP _ (UN fi) _) (EP _ (UN intTy) _))@@ -591,13 +626,6 @@ toConst :: Term -> Maybe Const toConst (Constant c) = Just c toConst _ = Nothing--stepForeign :: [ExecVal] -> Exec (Maybe ExecVal)-stepForeign (ty:fn:args) = let ffun = foreignFromTT fn- in case (call <$> ffun) of- Just f -> f args- Nothing -> return Nothing-stepForeign _ = fail "Tried to call foreign function that wasn't mkForeignPrim" mapMaybeM :: (Functor m, Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f [] = return []
src/Idris/Core/ProofState.hs view
@@ -6,7 +6,7 @@ module Idris.Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus, Tactic(..), Goal(..), processTactic, nowElaboratingPS, doneElaboratingAppPS,- doneElaboratingArgPS, dropGiven, keepGiven) where+ doneElaboratingArgPS, dropGiven, keepGiven, getProvenance) where import Idris.Core.Typecheck import Idris.Core.Evaluate@@ -23,23 +23,23 @@ import Util.Pretty hiding (fill) data ProofState = PS { thname :: Name,- holes :: [Name], -- holes still to be solved- usedns :: [Name], -- used names, don't use again- nextname :: Int, -- name supply- pterm :: ProofTerm, -- current proof term- ptype :: Type, -- original goal- dontunify :: [Name], -- explicitly given by programmer, leave it+ holes :: [Name], -- ^ holes still to be solved+ usedns :: [Name], -- ^ used names, don't use again+ nextname :: Int, -- ^ name supply+ pterm :: ProofTerm, -- ^ current proof term+ ptype :: Type, -- ^ original goal+ dontunify :: [Name], -- ^ explicitly given by programmer, leave it unified :: (Name, [(Name, Term)]), notunified :: [(Name, Term)],- dotted :: [(Name, [Name])], -- dot pattern holes + environment- -- either hole or something in env must turn up in the 'notunified' list during elaboration+ dotted :: [(Name, [Name])], -- ^ dot pattern holes + environment+ -- either hole or something in env must turn up in the 'notunified' list during elaboration solved :: Maybe (Name, Term), problems :: Fails, injective :: [Name],- deferred :: [Name], -- names we'll need to define- instances :: [Name], -- instance arguments (for type classes)- autos :: [(Name, [Name])], -- unsolved 'auto' implicits with their holes- previous :: Maybe ProofState, -- for undo+ deferred :: [Name], -- ^ names we'll need to define+ instances :: [Name], -- ^ instance arguments (for type classes)+ autos :: [(Name, [Name])], -- ^ unsolved 'auto' implicits with their holes+ previous :: Maybe ProofState, -- ^ for undo context :: Context, plog :: String, unifylog :: Bool,@@ -50,6 +50,7 @@ data Tactic = Attack | Claim Name Raw+ | ClaimFn Name Name Raw | Reorder Name | Exact Raw | Fill Raw@@ -87,6 +88,7 @@ | MoveLast Name | MatchProblems Bool | UnifyProblems+ | UnifyGoal Raw | ProofState | Undo | QED@@ -152,9 +154,11 @@ qshow :: Fails -> String qshow fs = show (map (\ (x, y, hs, _, _, _, t) -> (t, x, y, hs)) fs) -match_unify' :: Context -> Env -> TT Name -> TT Name ->+match_unify' :: Context -> Env -> + (TT Name, Maybe Provenance) -> + (TT Name, Maybe Provenance) -> StateT TState TC [(Name, TT Name)]-match_unify' ctxt env topx topy =+match_unify' ctxt env (topx, xfrom) (topy, yfrom) = do ps <- get let while = while_elaborating ps let dont = dontunify ps@@ -166,7 +170,7 @@ ++ "\n" ++ "\n" ++ show (getProofTerm (pterm ps)) ++ "\n\n" ) $- case match_unify ctxt env topx topy inj (holes ps) while of+ case match_unify ctxt env (topx, xfrom) (topy, yfrom) inj (holes ps) while of OK u -> traceWhen (unifylog ps) ("Matched " ++ show u) $ do let (h, ns) = unified ps@@ -193,14 +197,17 @@ | Just t' <- lookup n ns = do ps <- get let probs = problems ps- put (ps { problems = probs ++ [(t,t',True,env,Msg "New problem",+ put (ps { problems = probs ++ [(t,t',True,env,+ CantUnify True (t, Nothing) (t', Nothing) (Msg "") (errEnv env) 0, [], Unify)] }) merge acc ns | otherwise = merge ((n, t): acc) ns -unify' :: Context -> Env -> TT Name -> TT Name ->+unify' :: Context -> Env -> + (TT Name, Maybe Provenance) -> + (TT Name, Maybe Provenance) -> StateT TState TC [(Name, TT Name)]-unify' ctxt env topx topy =+unify' ctxt env (topx, xfrom) (topy, yfrom) = do ps <- get let while = while_elaborating ps let dont = dontunify ps@@ -213,7 +220,7 @@ "\nHoles: " ++ show (holes ps) ++ "\nInjective: " ++ show (injective ps) ++ "\n") $- lift $ unify ctxt env topx topy inj (holes ps)+ lift $ unify ctxt env (topx, xfrom) (topy, yfrom) inj (holes ps) (map fst (notunified ps)) while let notu = filter (\ (n, t) -> case t of -- P _ _ _ -> False@@ -287,12 +294,12 @@ 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 [] []+ ty' = vToP ty+ in PS n [h] [] 1 (mkProofTerm (Bind h (Hole ty')+ (P Bound h ty'))) ty [] (h, []) [] []+ Nothing [] []+ [] [] []+ Nothing ctxt "" False False [] [] type TState = ProofState -- [TacticAction]) type RunTactic = RunTactic' TState@@ -339,8 +346,19 @@ lift $ isType ctxt env tyt action (\ps -> let (g:gs) = holes ps in ps { holes = g : n : gs } )- return $ Bind n (Hole tyv) t -- (weakenTm 1 t)+ return $ Bind n (Hole tyv) t +-- If the current goal is 'retty', make a claim which is a function that+-- can compute a retty from argty (i.e a claim 'argty -> retty')+claimFn :: Name -> Name -> Raw -> RunTactic+claimFn n bn argty ctxt env t@(Bind x (Hole retty) sc) =+ do (tyv, tyt) <- lift $ check ctxt env argty+ lift $ isType ctxt env tyt+ action (\ps -> let (g:gs) = holes ps in+ ps { holes = g : n : gs } )+ return $ Bind n (Hole (Bind bn (Pi Nothing tyv tyt) retty)) t+claimFn _ _ _ ctxt env _ = fail "Can't make function type here"+ reorder_claims :: RunTactic reorder_claims ctxt env t = -- trace (showSep "\n" (map show (scvs t))) $@@ -439,6 +457,12 @@ regret ctxt env (Bind x (Hole t) _) = fail $ show x ++ " : " ++ show t ++ " is not solved..." +unifyGoal :: Raw -> RunTactic+unifyGoal tm ctxt env h@(Bind x b sc) =+ do (tmv, _) <- lift $ check ctxt env tm+ ns' <- unify' ctxt env (binderTy b, Nothing) (tmv, Nothing)+ return h+ exact :: Raw -> RunTactic exact guess ctxt env (Bind x (Hole ty) sc) = do (val, valty) <- lift $ check ctxt env guess@@ -453,12 +477,20 @@ do (val, valty) <- lift $ check ctxt env guess -- let valtyn = normalise ctxt env valty -- let tyn = normalise ctxt env ty- ns <- unify' ctxt env valty ty+ ns <- unify' ctxt env (valty, Just $ SourceTerm val)+ (ty, Just (chkPurpose val ty)) ps <- get let (uh, uns) = unified ps -- put (ps { unified = (uh, uns ++ ns) }) -- addLog (show (uh, uns ++ ns)) return $ Bind x (Guess ty val) sc+ where+ -- some expected types show up commonly in errors and indicate a+ -- specific problem.+ -- argTy -> retTy suggests a function applied to too many arguments+ chkPurpose val (Bind _ (Pi _ (P _ (MN _ _) _) _) (P _ (MN _ _) _))+ = TooManyArgs val+ chkPurpose _ _ = ExpectedType fill _ _ _ _ = fail "Can't fill here." -- As fill, but attempts to solve other goals by matching@@ -468,7 +500,8 @@ do (val, valty) <- lift $ check ctxt env guess -- let valtyn = normalise ctxt env valty -- let tyn = normalise ctxt env ty- ns <- match_unify' ctxt env valty ty+ ns <- match_unify' ctxt env (valty, Just $ SourceTerm val) + (ty, Just ExpectedType) ps <- get let (uh, uns) = unified ps -- put (ps { unified = (uh, uns ++ ns) })@@ -486,7 +519,8 @@ complete_fill ctxt env (Bind x (Guess ty val) sc) = do let guess = forget val (val', valty) <- lift $ check ctxt env guess- ns <- unify' ctxt env valty ty+ ns <- unify' ctxt env (valty, Just $ SourceTerm val') + (ty, Just ExpectedType) ps <- get let (uh, uns) = unified ps -- put (ps { unified = (uh, uns ++ ns) })@@ -504,12 +538,14 @@ dropdots <- case lookup x (notunified ps) of Just tm -> -- trace ("NEED MATCH: " ++ show (x, tm, val) ++ "\nIN " ++ show (pterm ps)) $- do match_unify' ctxt env tm val+ do match_unify' ctxt env (tm, Just InferredVal) + (val, Just GivenVal) return [x] _ -> return [] action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping hole " ++ show x) $ holes ps \\ [x], solved = Just (x, val),+ dontunify = filter (/= x) (dontunify ps), notunified = updateNotunified [(x,val)] (notunified ps), recents = x : recents ps,@@ -546,7 +582,7 @@ -- ns <- lift $ unify ctxt env tyv t' case t' of Bind y (Pi _ s _) t -> let t' = subst y (P Bound n s) t in- do ns <- unify' ctxt env s tyv+ do ns <- unify' ctxt env (s, Nothing) (tyv, Nothing) ps <- get let (uh, uns) = unified ps -- put (ps { unified = (uh, uns ++ ns) })@@ -572,8 +608,8 @@ forall :: Name -> Maybe ImplicitInfo -> Raw -> RunTactic forall n impl ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do (tyv, tyt) <- lift $ check ctxt env ty- unify' ctxt env tyt (TType (UVar 0))- unify' ctxt env t (TType (UVar 0))+ unify' ctxt env (tyt, Nothing) (TType (UVar 0), Nothing)+ unify' ctxt env (t, Nothing) (TType (UVar 0), Nothing) return $ Bind n (Pi impl tyv (TType (UVar 0))) (Bind x (Hole t) (P Bound x t)) forall n impl ty ctxt env _ = fail "Can't pi bind here" @@ -582,6 +618,7 @@ do action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping pattern hole " ++ show x) $ holes ps \\ [x], solved = Just (x, P Bound n t),+ dontunify = filter (/=x) (dontunify ps), notunified = updateNotunified [(x,P Bound n t)] (notunified ps), injective = addInj n x (injective ps)@@ -644,8 +681,8 @@ (tmv, tmt) <- lift $ check ctxt env tm let tmt' = normalise ctxt env tmt let (tacn, tacstr, tactt) = if induction- then (ElimN, "an eliminator", "Induction")- else (CaseN, "a case function", "Case analysis")+ then (ElimN, "eliminator", "Induction")+ else (CaseN, "case analysis", "Case analysis") case unApply tmt' of (P _ tnm _, tyargs) -> do case lookupTy (SN (tacn tnm)) ctxt of@@ -680,9 +717,10 @@ (scv, sct) <- lift $ check ctxt env res' let (scv', _) = specialise ctxt env [] scv return scv'- [] -> lift $ tfail $ Msg $ tactt ++ " needs " ++ tacstr ++ " for " ++ show tnm+ [] -> lift $ tfail $ NoEliminator tacstr tmt' xs -> lift $ tfail $ Msg $ "Multiple definitions found when searching for " ++ tacstr ++ "of " ++ show tnm- _ -> fail $ "Unkown type for " ++ if induction then "induction" else "case analysis"+ _ -> lift $ tfail $ NoEliminator (if induction then "induction" else "case analysis")+ tmt' where scname = sMN 0 "scarg" makeConsArg (nm, ty) = P Bound nm ty bindConsArgs ((nm, ty):args) v = Bind nm (Hole ty) $ bindConsArgs args v@@ -795,13 +833,17 @@ updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env +updateProv ns (SourceTerm t) = SourceTerm $ updateSolvedTerm ns t+updateProv ns p = p+ updateError [] err = err updateError ns (At f e) = At f (updateError ns e) updateError ns (Elaborating s n e) = Elaborating s n (updateError ns e) updateError ns (ElaboratingArg f a env e) = ElaboratingArg f a env (updateError ns e)-updateError ns (CantUnify b l r e xs sc)- = CantUnify b (updateSolvedTerm ns l) (updateSolvedTerm ns r) (updateError ns e) xs sc+updateError ns (CantUnify b (l,lp) (r,rp) e xs sc)+ = CantUnify b (updateSolvedTerm ns l, fmap (updateProv ns) lp) + (updateSolvedTerm ns r, fmap (updateProv ns) rp) (updateError ns e) xs sc updateError ns e = e solveInProblems x val [] = []@@ -815,7 +857,7 @@ mnu ((n, t):ns) ns_acc ps_acc | Just t' <- lookup n ns, t /= t' = mnu ns ((n,t') : ns_acc)- ((t,t',True, env,CantUnify True t t' (Msg "") [] 0, [],Match) : ps_acc)+ ((t,t',True, env,CantUnify True (t, Nothing) (t', Nothing) (Msg "") [] 0, [],Match) : ps_acc) | otherwise = mnu ns ((n,t) : ns_acc) ps_acc updateNotunified [] nu = nu@@ -824,6 +866,10 @@ up ((n, t) : nus) = let t' = updateSolvedTerm ns t in ((n, t') : up nus) +getProvenance :: Err -> (Maybe Provenance, Maybe Provenance)+getProvenance (CantUnify _ (_, lp) (_, rp) _ _ _) = (lp, rp)+getProvenance _ = (Nothing, Nothing)+ updateProblems :: ProofState -> [(Name, TT Name)] -> Fails -> ([(Name, TT Name)], Fails) -- updateProblems ctxt [] ps inj holes = ([], ps)@@ -831,19 +877,23 @@ hs = holes ps inj = injective ps ctxt = context ps+ ulog = unifylog ps usupp = map fst (notunified ps)+ dont = dontunify ps up ns [] = (ns, []) up ns (prob@(x, y, ready, env, err, while, um) : ps) = let (x', newx) = updateSolvedTerm' ns x (y', newy) = updateSolvedTerm' ns y+ (lp, rp) = getProvenance err err' = updateError ns err env' = updateEnv ns env in if newx || newy || ready || any (\n -> n `elem` inj) (refsIn x ++ refsIn y) then - case unify ctxt env' x' y' inj hs usupp while of- OK (v, []) -> -- trace ("DID " ++ show (x',y',ready,v)) $- up (ns ++ v) ps+ 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 e -> -- trace ("FAILED " ++ show (x',y',ready,e)) $ let (ns', ps') = up ns ps in (ns', (x',y', False, env',err', while, um) : ps')@@ -864,9 +914,10 @@ | all || um == Match = let x' = updateSolvedTerm ns x y' = updateSolvedTerm ns y+ (lp, rp) = getProvenance err err' = updateError ns err env' = updateEnv ns env in- case match_unify ctxt env' x' y' inj hs while of+ case match_unify ctxt env' (x', lp) (y', rp) inj hs while of OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $ up (ns ++ v) ps _ -> let (ns', ps') = up ns ps in@@ -891,7 +942,7 @@ ns' = map (\ (n, t) -> (n, updateSolvedTerm ns t)) ns (ns'', probs') = updateProblems ps ns' (problems ps) tm' = updateSolved ns'' (pterm ps) in- traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $+ traceWhen (unifylog ps) ("(EndUnify) Dropping holes: " ++ show (map fst ns'')) $ return (ps { pterm = tm', unified = (h, []), problems = probs',@@ -914,7 +965,7 @@ processTactic UnifyProblems ps = do let (ns', probs') = updateProblems ps [] (problems ps) pterm' = updateSolved ns' (pterm ps)- traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns')) $+ traceWhen (unifylog ps) ("(UnifyProblems) Dropping holes: " ++ show (map fst ns')) $ return (ps { pterm = pterm', solved = Nothing, problems = probs', previous = Just ps, plog = "", notunified = updateNotunified ns' (notunified ps),@@ -924,7 +975,7 @@ = do let (ns', probs') = matchProblems all ps [] (problems ps) (ns'', probs'') = matchProblems all ps ns' probs' pterm' = updateSolved ns'' (pterm ps)- traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $+ traceWhen (unifylog ps) ("(MatchProblems) Dropping holes: " ++ show (map fst ns'')) $ return (ps { pterm = pterm', solved = Nothing, problems = probs'', previous = Just ps, plog = "", notunified = updateNotunified ns'' (notunified ps),@@ -934,16 +985,19 @@ = case holes ps of [] -> fail "Nothing to fill in." (h:_) -> do ps' <- execStateT (process t h) ps- let (ns', probs')+ let (ns_in, probs') = case solved ps' of- Just s -> traceWhen (unifylog ps')- ("SOLVED " ++ show s) $- updateProblems ps [s] (problems ps')+ Just s -> traceWhen (unifylog ps)+ ("SOLVED " ++ show s ++ " " ++ show (dontunify ps')) $+ updateProblems ps' [s] (problems ps') _ -> ([], problems ps') -- rechecking problems may find more solutions, so -- apply them here+ let ns' = dropGiven (dontunify ps') ns_in (holes ps') let pterm'' = updateSolved ns' (pterm ps')- traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns')) $+ traceWhen (unifylog ps) + ("Updated problems after solve " ++ qshow probs' ++ "\n" +++ "(Toplevel) Dropping holes: " ++ show (map fst ns')) $ return (ps' { pterm = pterm'', solved = Nothing, problems = probs',@@ -960,12 +1014,12 @@ process t h = tactic (Just h) (mktac t) where mktac Attack = attack mktac (Claim n r) = claim n r+ mktac (ClaimFn n bn r) = claimFn n bn r mktac (Exact r) = exact r mktac (Fill r) = fill r mktac (MatchFill r) = match_fill r mktac (PrepFill n ns) = prep_fill n ns mktac CompleteFill = complete_fill- mktac Regret = regret mktac Solve = solve mktac (StartUnify n) = start_unify n mktac Compute = compute@@ -991,3 +1045,4 @@ mktac (AutoArg n) = autoArg n mktac (SetInjective n) = setinj n mktac (MoveLast n) = movelast n+ mktac (UnifyGoal r) = unifyGoal r
src/Idris/Core/ProofTerm.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-} -{- Implements a proof state, some primitive tactics for manipulating- proofs, and some high level commands for introducing new theorems,- evaluation/checking inside the proof system, etc. --}+{- | Implements a proof state, some primitive tactics for manipulating+proofs, and some high level commands for introducing new theorems,+evaluation/checking inside the proof system, etc.+-} module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm, updateSolved, updateSolvedTerm, updateSolvedTerm',@@ -18,6 +19,7 @@ import Data.List import Debug.Trace +-- | A zipper over terms, in order to efficiently update proof terms. data TermPath = Top | AppL TermPath Term | AppR Term TermPath@@ -25,6 +27,7 @@ | InScope Name (Binder Term) TermPath deriving Show +-- | A zipper over binders, because terms and binders are mutually defined. data BinderPath = Binder (Binder TermPath) | LetT TermPath Term | LetV Term TermPath@@ -32,6 +35,8 @@ | GuessV Term TermPath deriving Show +-- | Replace the top of a term path with another term path. In other+-- 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@@ -45,6 +50,7 @@ replaceTopB p (GuessV t v) = GuessV t (replaceTop p v) replaceTop p (InScope n b sc) = InScope n b (replaceTop p sc) +-- | 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@@ -52,6 +58,7 @@ rebuildTerm tm (InScope n b p) = Bind n b (rebuildTerm tm p) rebuildTerm tm (InBind n bp sc) = Bind n (rebuildBinder tm bp) sc +-- | Build a binder from a zipper, given something to put in the hole. rebuildBinder :: Term -> BinderPath -> Binder Term rebuildBinder tm (Binder p) = fmap (rebuildTerm tm) p rebuildBinder tm (LetT p t) = Let (rebuildTerm tm p) t@@ -59,6 +66,9 @@ rebuildBinder tm (GuessT p t) = Guess (rebuildTerm tm p) t rebuildBinder tm (GuessV v p) = Guess v (rebuildTerm tm p) +-- | Find the binding of a hole in a term. If present, return the path+-- to the hole's binding, the environment extended by the binders that+-- are crossed, and the actual binding term. findHole :: Name -> Env -> Term -> Maybe (TermPath, Env, Term) findHole n env t = fh' env Top t where fh' env path tm@(Bind x h sc) @@ -80,7 +90,7 @@ fhB env path b | Just (p, env', tm) <- fh' env path (binderTy b) = Just (Binder (fmap (\_ -> p) b), env', tm)- fhB _ _ _ = Nothing + fhB _ _ _ = Nothing data ProofTerm = PT { -- wholeterm :: Term, path :: TermPath,@@ -92,13 +102,17 @@ type RunTactic' a = Context -> Env -> Term -> StateT a TC Term type Hole = Maybe Name -- Nothing = default hole, first in list in proof state +-- | Refocus the proof term zipper on a particular hole, if it+-- exists. If not, return the original proof term. refocus :: Hole -> ProofTerm -> ProofTerm refocus h t = let res = refocus' h t in res -- trace ("OLD: " ++ show t ++ "\n" ++ -- "REFOCUSSED " ++ show h ++ ": " ++ show res) res refocus' (Just n) pt@(PT path env tm ups)+ -- 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 | Just (p', env', tm') <- findHole n [] (rebuildTerm tm (updateSolvedPath ups path)) = PT p' env' tm' [] | otherwise = pt@@ -118,27 +132,32 @@ same Nothing n = True same (Just x) n = x == n +-- | Is a particular binder a hole or a guess? hole :: Binder b -> Bool hole (Hole _) = True hole (Guess _ _) = True hole _ = False -updateSolvedTerm :: [(Name, Term)] -> Term -> Term +-- | Given a list of solved holes, fill out the solutions in a term+updateSolvedTerm :: [(Name, Term)] -> Term -> Term updateSolvedTerm xs x = fst $ updateSolvedTerm' xs x +-- | Given a list of solved holes, fill out the solutions in a+-- term. Return whether updates were performed, to facilitate sharing+-- when there are no updates.+updateSolvedTerm' :: [(Name, Term)] -> Term -> (Term, Bool) updateSolvedTerm' [] x = (x, False)-updateSolvedTerm' xs x = -- updateSolved' xs x where--- This version below saves allocations, because it doesn't need to reallocate--- the term if there are no updates to do. --- The Bool is ugly, and probably 'Maybe' would be less ugly, but >>= is--- the wrong combinator. Feel free to tidy up as long as it's still as cheap :).- updateSolved' xs x where+updateSolvedTerm' xs x = updateSolved' xs x where+ -- This version below saves allocations, because it doesn't need to reallocate+ -- the term if there are no updates to do.+ -- The Bool is ugly, and probably 'Maybe' would be less ugly, but >>= is+ -- the wrong combinator. Feel free to tidy up as long as it's still as cheap :). updateSolved' [] x = (x, False) updateSolved' xs (Bind n (Hole ty) t)- | Just v <- lookup n xs + | Just v <- lookup n xs = case xs of [_] -> (subst n v t, True) -- some may be Vs! Can't assume- -- explicit names+ -- explicit names _ -> let (t', _) = updateSolved' xs t in (subst n v t', True) updateSolved' xs tm@(Bind n b t)@@ -146,13 +165,16 @@ (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 f a) = let (f', uf) = updateSolved' xs f (a', ua) = updateSolved' xs a in if uf || ua then (App f' a', True) else (t, False) updateSolved' xs t@(P _ n@(MN _ _) _) | Just v <- lookup n xs = (v, True)+ updateSolved' xs t@(P nt n ty)+ = let (ty', ut) = updateSolved' xs ty in+ if ut then (P nt n ty', True) else (t, False) updateSolved' xs t = (t, False) updateSolvedB' xs b@(Let t v) = let (t', ut) = updateSolved' xs t @@ -176,10 +198,14 @@ noneOfB ns b = noneOf ns (binderTy b) noneOf ns _ = True +-- | Apply solutions to an environment.+updateEnv :: [(Name, Term)] -> Env -> Env updateEnv [] e = e updateEnv ns [] = [] updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env +-- | Fill out solved holes in a term zipper.+updateSolvedPath :: [(Name, Term)] -> TermPath -> TermPath updateSolvedPath [] t = t updateSolvedPath ns Top = Top updateSolvedPath ns (AppL p r) = AppL (updateSolvedPath ns p) (updateSolvedTerm ns r)
src/Idris/Core/TT.hs view
@@ -30,7 +30,7 @@ import Data.Data (Data) import Numeric (showIntAtBase) import qualified Data.Text as T-import Data.List hiding (insert)+import Data.List hiding (group, insert) import Data.Set(Set, member, fromList, insert) import Data.Maybe (listToMaybe) import Data.Foldable (Foldable)@@ -53,7 +53,7 @@ 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) + deriving (Data, Typeable, Ord) -- | Ignore source location equality (so deriving classes do not compare FCs) instance Eq FC where@@ -120,12 +120,25 @@ -- Please remember to keep Err synchronised with -- Language.Reflection.Errors.Err in the stdlib! +data Provenance = ExpectedType+ | TooManyArgs Term+ | InferredVal+ | GivenVal+ | SourceTerm Term+ deriving (Show, Eq, Data, Typeable)+{-!+deriving instance NFData Err+deriving instance Binary Err+!-}+ -- | Idris errors. Used as exceptions in the compiler, but reported to users -- if they reach the top level. data Err' t = Msg String | InternalMsg String- | CantUnify Bool t t (Err' t) [(Name, t)] Int+ | CantUnify Bool (t, Maybe Provenance) -- Expected type, provenance+ (t, Maybe Provenance) -- Actual type, provenance+ (Err' t) [(Name, t)] Int -- Int is 'score' - how much we did unify -- Bool indicates recoverability, True indicates more info may make -- unification succeed@@ -142,9 +155,12 @@ | WithFnType t | NoTypeDecl Name | NotInjective t t t- | CantResolve t+ | CantResolve Bool -- True if postponed, False if fatal+ t+ | InvalidTCArg Name t | CantResolveAlts [Name] | IncompleteTerm t+ | NoEliminator String t | UniverseError | UniqueError Universe Name | UniqueKindError Universe Name@@ -162,6 +178,8 @@ | LoadingFailed String (Err' t) | ReflectionError [[ErrorReportPart]] (Err' t) | ReflectionFailed String (Err' t)+ | ElabDebug (Maybe String) t [(Name, t, [(Name, Binder t)])]+ -- ^ User-specified message, proof term, goals with context (first goal is focused) deriving (Eq, Functor, Data, Typeable) type Err = Err' Term@@ -209,14 +227,14 @@ instance Sized Err where size (Msg msg) = length msg size (InternalMsg msg) = length msg- size (CantUnify _ left right err _ score) = size left + size right + size err+ size (CantUnify _ left right err _ score) = size (fst left) + size (fst right) + size err size (InfiniteUnify _ right _) = size right size (CantConvert left right _) = size left + size right size (UnifyScope _ _ right _) = size right size (NoSuchVariable name) = size name size (NoTypeDecl name) = size name size (NotInjective l c r) = size l + size c + size r- size (CantResolve trm) = size trm+ size (CantResolve _ trm) = size trm size (NoRewriting trm) = size trm size (CantResolveAlts _) = 1 size (IncompleteTerm trm) = size trm@@ -231,7 +249,7 @@ score :: Err -> Int score (CantUnify _ _ _ m _ s) = s + score m-score (CantResolve _) = 20+score (CantResolve _ _) = 20 score (NoSuchVariable _) = 1000 score (ProofSearchFail e) = score e score (CantSolveGoal _ _) = 100000@@ -261,7 +279,7 @@ instance Pretty Err OutputAnnotation where pretty (Msg m) = text m- pretty (CantUnify _ l r e _ i) =+ pretty (CantUnify _ (l, _) (r, _) e _ i) = text "Cannot unify" <+> colon <+> pretty l <+> text "and" <+> pretty r <+> nest nestingSize (text "where" <+> pretty e <+> text "with" <+> (text . show $ i)) pretty (ProviderError msg) = text msg@@ -492,7 +510,7 @@ toAlist ctxt = let allns = map snd (Map.toList ctxt) in concatMap (Map.toList) allns -addAlist :: Show a => [(Name, a)] -> Ctxt a -> Ctxt a+addAlist :: [(Name, a)] -> Ctxt a -> Ctxt a addAlist [] ctxt = ctxt addAlist ((n, tm) : ds) ctxt = addDef n tm (addAlist ds ctxt) @@ -550,6 +568,7 @@ | B8V (Vector Word8) | B16V (Vector Word16) | B32V (Vector Word32) | B64V (Vector Word64) | AType ArithTy | StrType+ | WorldType | TheWorld | PtrType | ManagedPtrType | BufferType | VoidType | Forgot deriving (Eq, Ord, Data, Typeable) {-!@@ -562,6 +581,7 @@ isTypeConst StrType = True isTypeConst ManagedPtrType = True isTypeConst BufferType = True+isTypeConst WorldType = True isTypeConst PtrType = True isTypeConst VoidType = True isTypeConst _ = False@@ -577,6 +597,8 @@ pretty (Str s) = text s pretty (AType a) = pretty a 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"@@ -777,7 +799,7 @@ -- | Universe constraints data UConstraint = ULT UExp UExp -- ^ Strictly less than | ULE UExp UExp -- ^ Less than or equal to- deriving Eq+ deriving (Eq, Ord) instance Show UConstraint where show (ULT x y) = show x ++ " < " ++ show y@@ -915,6 +937,7 @@ -- | Replace the outermost (index 0) de Bruijn variable with the given term instantiate :: TT n -> TT n -> TT n instantiate e = subst 0 where+ subst i (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)@@ -926,6 +949,7 @@ -- 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 (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)@@ -1019,6 +1043,9 @@ -- 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@@ -1144,18 +1171,34 @@ forget :: TT Name -> Raw forget tm = forgetEnv [] tm +safeForget :: TT Name -> Maybe Raw+safeForget tm = safeForgetEnv [] tm+ forgetEnv :: [Name] -> TT Name -> Raw-forgetEnv env (P _ n _) = Var n-forgetEnv env (V i) = Var (env !! i)-forgetEnv env (Bind n b sc) = let n' = uniqueName n env in- RBind n' (fmap (forgetEnv env) b)- (forgetEnv (n':env) sc)-forgetEnv env (App f a) = RApp (forgetEnv env f) (forgetEnv env a)-forgetEnv env (Constant c) = RConstant c-forgetEnv env (TType i) = RType-forgetEnv env (UType u) = RUType u-forgetEnv env Erased = RConstant Forgot+forgetEnv env tm = case safeForgetEnv env tm of+ Just t' -> t'+ Nothing -> error $ "Scope error in " ++ show tm ++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) + = 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) + (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)+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+ -- | Introduce a 'Bind' into the given term for each element of the -- given list of (name, binder) pairs. bindAll :: [(n, Binder (TT n))] -> TT n -> TT n@@ -1266,6 +1309,8 @@ 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"@@ -1339,6 +1384,8 @@ = (show $ fst $ env!!i) ++ if dbg then "{" ++ show i ++ "}" else "" | otherwise = "!!V " ++ show i ++ "!!"+ se p env (Bind n b@(Pi (Just _) t k) sc)+ = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc se p env (Bind n b@(Pi _ t k) sc) | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ arrow k ++ se 10 ((n,b):env) sc where arrow (TType _) = " -> "@@ -1355,6 +1402,7 @@ sb env n (Lam t) = showb env "\\ " " => " n t sb env n (Hole t) = showb env "? " ". " n t sb env n (GHole i t) = showb env "?defer " ". " n t+ sb env n (Pi (Just _) t _) = showb env "{" "} -> " n t sb env n (Pi _ t _) = showb env "(" ") -> " n t sb env n (PVar t) = showb env "pat " ". " n t sb env n (PVTy t) = showb env "pty " ". " n t@@ -1487,3 +1535,99 @@ nb t = allNamesIn (binderTy t) allNamesIn (App f a) = allNamesIn f ++ allNamesIn a allNamesIn _ = []+++-- | Pretty-print a term+pprintTT :: [Name] -- ^ The bound names (for highlighting and de Bruijn indices)+ -> TT Name -- ^ The term to be printed+ -> Doc OutputAnnotation+pprintTT bound tm = pp startPrec bound tm++ where+ startPrec = 0+ appPrec = 10++ pp p bound (P Bound n ty) = annotate (AnnBoundName n False) (text $ show n)+ pp p bound (P nt n ty) = annotate (AnnName n Nothing Nothing Nothing)+ (text $ show n)+ pp p bound (V i)+ | i < length bound = let n = bound !! i+ in annotate (AnnBoundName n False) (text $ show n)+ | 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) =+ bracket p appPrec . group . hang 2 $+ pp appPrec bound tm1 <> line <>+ pp (appPrec + 1) bound tm2+ pp p bound (Constant c) = annotate (AnnConst c) (text (show c))+ pp p bound (Proj tm i) =+ lparen <> pp startPrec bound tm <> rparen <>+ text "!" <> text (show i)+ pp p bound Erased = text "<<<erased>>>"+ pp p bound Impossible = text "<<<impossible>>>"+ pp p bound (TType ue) = annotate (AnnType "Type" "The type of types") $+ text "Type"+ pp p bound (UType u) = text (show u)++ ppb p bound n (Lam ty) sc =+ bracket p startPrec . group . align . hang 2 $+ text "λ" <+> bindingOf n False <+> text "." <> line <> sc+ ppb p bound n (Pi _ ty k) sc =+ bracket p startPrec . group . align $+ lparen <> (bindingOf n False) <+> colon <+>+ (group . align) (pp startPrec bound ty) <>+ rparen <+> mkArrow k <> line <> sc+ where mkArrow (UType UniqueType) = text "⇴"+ mkArrow (UType NullType) = text "⥛"+ mkArrow _ = text "→"+ ppb p bound n (Let ty val) sc =+ bracket p startPrec . group . align $+ (group . hang 2) (annotate AnnKeyword (text "let") <+>+ bindingOf n False <+> colon <+>+ pp startPrec bound ty <+>+ text "=" <> line <>+ pp startPrec bound val) <> line <>+ (group . hang 2) (annotate AnnKeyword (text "in") <+> sc)+ ppb p bound n (NLet ty val) sc =+ bracket p startPrec . group . align $+ (group . hang 2) (annotate AnnKeyword (text "nlet") <+>+ bindingOf n False <+> colon <+>+ pp startPrec bound ty <+>+ text "=" <> line <>+ pp startPrec bound val) <> line <>+ (group . hang 2) (annotate AnnKeyword (text "in") <+> sc)+ ppb p bound n (Hole ty) sc =+ bracket p startPrec . group . align . hang 2 $+ text "?" <+> bindingOf n False <+> text "." <> line <> sc+ ppb p bound n (GHole _ ty) sc =+ bracket p startPrec . group . align . hang 2 $+ text "¿" <+> bindingOf n False <+> text "." <> line <> sc+ ppb p bound n (Guess ty val) sc =+ bracket p startPrec . group . align . hang 2 $+ text "?" <> bindingOf n False <+>+ text "≈" <+> pp startPrec bound val <+>+ text "." <> line <> sc+ ppb p bound n (PVar ty) sc =+ bracket p startPrec . group . align . hang 2 $+ annotate AnnKeyword (text "pat") <+>+ bindingOf n False <+> colon <+> pp startPrec bound ty <+>+ text "." <> line <>+ sc+ ppb p bound n (PVTy ty) sc =+ bracket p startPrec . group . align . hang 2 $+ annotate AnnKeyword (text "patTy") <+>+ bindingOf n False <+> colon <+> pp startPrec bound ty <+>+ text "." <> line <>+ sc++ bracket outer inner doc+ | outer > inner = lparen <> doc <> rparen+ | otherwise = doc+++-- | Pretty-printer helper for the binding site of a name+bindingOf :: Name -- ^^ the bound name+ -> Bool -- ^^ whether the name is implicit+ -> Doc OutputAnnotation+bindingOf n imp = annotate (AnnBoundName n imp) (text (show n))
src/Idris/Core/Typecheck.hs view
@@ -81,7 +81,10 @@ Env -> Raw -> StateT UCs TC (Term, Type) chk u env (Var n) | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty)- | (P nt n' ty : _) <- lookupP n ctxt = return (P nt n' ty, ty)+ -- 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) | otherwise = do lift $ tfail $ NoSuchVariable n chk u env ap@(RApp f a) = do (fv, fty) <- chk u env f@@ -129,6 +132,7 @@ 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) chk u env (RForce t) = do (_, ty) <- chk u env t
src/Idris/Core/Unify.hs view
@@ -51,7 +51,7 @@ | UFail Err -- | Smart constructor for unification errors that takes into account the FailContext-cantUnify :: [FailContext] -> Bool -> t -> t -> (Err' t) -> [(Name, t)] -> Int -> Err' t+cantUnify :: [FailContext] -> Bool -> (t, Maybe Provenance) -> (t, Maybe Provenance) -> (Err' t) -> [(Name, t)] -> Int -> Err' t cantUnify [] r t1 t2 e ctxt i = CantUnify r t1 t2 e ctxt i cantUnify (FailContext fc f x : prev) r t1 t2 e ctxt i = At fc (ElaboratingArg f x@@ -61,13 +61,15 @@ -- Solve metavariables by matching terms against each other -- Not really unification, of course! -match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->+match_unify :: Context -> Env -> + (TT Name, Maybe Provenance) -> + (TT Name, Maybe Provenance) -> [Name] -> [Name] -> [FailContext] -> TC [(Name, TT Name)]-match_unify ctxt env topx topy inj holes from =+match_unify ctxt env (topx, xfrom) (topy, yfrom) inj holes from = case runStateT (un [] (renameBindersTm env topx) (renameBindersTm env topy)) (UI 0 []) of OK (v, UI _ []) -> - do v' <- trimSolutions topx topy from env v+ do v' <- trimSolutions (topx, xfrom) (topy, yfrom) from env v return (map (renameBinders env) v') res -> let topxn = renameBindersTm env (normalise ctxt env topx)@@ -75,14 +77,14 @@ case runStateT (un [] topxn topyn) (UI 0 []) of OK (v, UI _ fails) ->- do v' <- trimSolutions topx topy from env v+ do v' <- trimSolutions (topx, xfrom) (topy, yfrom) from env v return (map (renameBinders env) v') Error e -> -- just normalise the term we're matching against case runStateT (un [] topxn topy) (UI 0 []) of OK (v, UI _ fails) ->- do v' <- trimSolutions topx topy from env v+ do v' <- trimSolutions (topx, xfrom) (topy, yfrom) from env v return (map (renameBinders env) v') _ -> tfail e where@@ -98,7 +100,7 @@ | (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)+ checkCycle names (f, Bind n' (Lam t) x) un names tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) x | (P (TCon _ _) _ _, _) <- unApply x, holeIn env f || f `elem` holes@@ -108,7 +110,7 @@ | (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)+ checkCycle names (f, Bind n' (Lam t) x) un names tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) x | (P (DCon _ _ _) _ _, _) <- unApply x, holeIn env f || f `elem` holes@@ -143,7 +145,7 @@ let r = recoverable (normalise ctxt env x) (normalise ctxt env y) let err = cantUnify from r- topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s+ (topx, xfrom) (topy, yfrom) (CantUnify r (x, Nothing) (y, Nothing) (Msg "") (errEnv env) s) (errEnv env) s if (not r) then lift $ tfail err else do put (UI s ((x, y, True, env, err, from, Match) : f)) lift $ tfail err@@ -153,12 +155,13 @@ h2 <- un bnames vx vy combine bnames h1 h2 uB bnames (Lam tx) (Lam ty) = un bnames tx ty- uB bnames (Pi _ tx _) (Pi _ ty _) = un bnames tx ty+ uB bnames (Pi i tx _) (Pi i' ty _) = un bnames tx ty uB bnames x y = do UI s f <- get let r = recoverable (normalise ctxt env (binderTy x)) (normalise ctxt env (binderTy y))- let err = cantUnify from r topx topy- (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)+ let err = cantUnify from r (topx, xfrom) (topy, yfrom)+ (CantUnify r (binderTy x, Nothing) + (binderTy y, Nothing) (Msg "") (errEnv env) s) (errEnv env) s put (UI s ((binderTy x, binderTy y, False,@@ -179,7 +182,8 @@ let r = recoverable (normalise ctxt env x) (normalise ctxt env y) let err = cantUnify from r- topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s+ (topx, xfrom) (topy, yfrom)+ (CantUnify r (x, Nothing) (y, Nothing) (Msg "") (errEnv env) s) (errEnv env) s put (UI s ((x, y, True, env, err, from, Match) : f)) lift $ tfail err combine bnames as [] = return as@@ -241,7 +245,7 @@ = Bind n (Hole ty) (instantiate (P Bound n ty) sc) explicitHole t = t -trimSolutions topx topy from env topns = followSols [] (dropPairs topns)+trimSolutions (topx, xfrom) (topy, yfrom) from env topns = followSols [] (dropPairs topns) where dropPairs [] = [] dropPairs (n@(x, P _ x' _) : ns) | x == x' = dropPairs ns@@ -258,7 +262,7 @@ = do vs' <- case t' of P _ tn _ -> if (n, tn) `elem` vs then -- cycle- tfail (cantUnify from False topx topy + tfail (cantUnify from False (topx, xfrom) (topy, yfrom) (Msg "") (errEnv env) 0) else return ((n, tn) : vs) _ -> return vs@@ -280,16 +284,18 @@ hasv (Bind x b sc) = hasv (binderTy b) || hasv sc hasv _ = False -unify :: Context -> Env -> TT Name -> TT Name ->+unify :: Context -> Env -> + (TT Name, Maybe Provenance) -> + (TT Name, Maybe Provenance) -> [Name] -> [Name] -> [Name] -> [FailContext] -> TC ([(Name, TT Name)], Fails)-unify ctxt env topx topy inj holes usersupp from =+unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from = -- traceWhen (hasv topx || hasv topy) -- ("Unifying " ++ show topx ++ "\nAND\n" ++ show topy ++ "\n") $ -- don't bother if topx and topy are different at the head case runStateT (un False [] (renameBindersTm env topx) (renameBindersTm env topy)) (UI 0 []) of- OK (v, UI _ []) -> do v' <- trimSolutions topx topy from env v+ OK (v, UI _ []) -> do v' <- trimSolutions (topx, xfrom) (topy, yfrom) from env v return (map (renameBinders env) v', []) res -> let topxn = renameBindersTm env (normalise ctxt env topx)@@ -298,7 +304,7 @@ case runStateT (un False [] topxn topyn) (UI 0 []) of OK (v, UI _ fails) ->- do v' <- trimSolutions topx topy from env v+ do v' <- trimSolutions (topx, xfrom) (topy, yfrom) from env v return (map (renameBinders env) v', reverse fails) -- Error e@(CantUnify False _ _ _ _ _) -> tfail e Error e -> tfail e@@ -461,8 +467,8 @@ h2 <- un' False (((x,y),binderTy bx):bnames) sx sy combine bnames h1 h2 where sameBinder (Lam _) (Lam _) = True- sameBinder (Pi _ _ _) (Pi _ _ _) = True- sameBinder _ _ = False+ sameBinder (Pi i _ _) (Pi i' _ _) = True+ sameBinder _ _ = False -- never unify holes/guesses/etc un' fn bnames x y | OK True <- convEq' ctxt holes x y = do sc 1; return [] | isUniverse x && isUniverse y = do sc 1; return []@@ -470,7 +476,7 @@ let r = recoverable (normalise ctxt env x) (normalise ctxt env y) let err = cantUnify from r- topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s+ (topx, xfrom) (topy, yfrom) (CantUnify r (x, Nothing) (y, Nothing) (Msg "") (errEnv env) s) (errEnv env) s if (not r) then lift $ tfail err else do put (UI s ((x, y, True, env, err, from, Unify) : f)) return [] -- lift $ tfail err@@ -569,7 +575,8 @@ = do UI s f <- get let r = recoverable (normalise ctxt env x) (normalise ctxt env y) let err = cantUnify from r- topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s+ (topx, xfrom) (topy, yfrom) + (CantUnify r (x, Nothing) (y, Nothing) (Msg "") (errEnv env) s) (errEnv env) s put (UI s ((topx, topy, True, env, err, from, Unify) : f)) return [] @@ -577,7 +584,8 @@ unifyFail x y = do UI s f <- get let r = recoverable (normalise ctxt env x) (normalise ctxt env y) let err = cantUnify from r- topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s+ (topx, xfrom) (topy, yfrom) + (CantUnify r (x, Nothing) (y, Nothing) (Msg "") (errEnv env) s) (errEnv env) s put (UI s ((topx, topy, True, env, err, from, Unify) : f)) lift $ tfail err @@ -599,8 +607,8 @@ uB bnames x y = do UI s f <- get let r = recoverable (normalise ctxt env (binderTy x)) (normalise ctxt env (binderTy y))- let err = cantUnify from r topx topy- (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)+ let err = cantUnify from r (topx, xfrom) (topy, yfrom)+ (CantUnify r (binderTy x, Nothing) (binderTy y, Nothing) (Msg "") (errEnv env) s) (errEnv env) s put (UI s ((binderTy x, binderTy y, False,
src/Idris/Coverage.hs view
@@ -18,18 +18,18 @@ import Control.Monad.State.Strict --- Generate a pattern from an 'impossible' LHS. (Need this to eliminate the--- pattern clauses which have been provided explicitly from new clause--- generation.)-+-- | Generate a pattern from an 'impossible' LHS.+--+-- We need this to eliminate the pattern clauses which have been+-- provided explicitly from new clause generation. mkPatTm :: PTerm -> Idris Term mkPatTm t = do i <- getIState- let timp = addImpl' True [] [] i t+ let timp = addImpl' True [] [] [] i t evalStateT (toTT (mapPT deNS timp)) 0 where toTT (PRef _ n) = do i <- lift getIState- case lookupDef n (tt_ctxt i) of- [TyDecl nt _] -> return $ P nt n Erased+ case lookupNameDef n (tt_ctxt i) of+ [(n', TyDecl nt _)] -> return $ P nt n' Erased _ -> return $ P Ref n Erased toTT (PApp _ t args) = do t' <- toTT t args' <- mapM (toTT . getTm) args@@ -44,13 +44,12 @@ deNS (PRef f (NS n _)) = PRef f n deNS t = t --- Given a list of LHSs, generate a extra clauses which cover the remaining--- cases. The ones which haven't been provided are marked 'absurd' so that the--- checker will make sure they can't happen.-+-- | Given a list of LHSs, generate a extra clauses which cover the remaining+-- cases. The ones which haven't been provided are marked 'absurd' so+-- that the checker will make sure they can't happen.+-- -- This will only work after the given clauses have been typechecked and the -- names are fully explicit!- genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm] genClauses fc n xs given = do i <- getIState
src/Idris/DSL.hs view
@@ -2,6 +2,8 @@ module Idris.DSL where +import Data.Generics.Uniplate.Data (transform)+ import Idris.AbsSyntax import Idris.Core.TT@@ -13,25 +15,55 @@ debindApp :: SyntaxInfo -> PTerm -> PTerm debindApp syn t = debind (dsl_bind (dsl_info syn)) t +dslify :: SyntaxInfo -> IState -> PTerm -> PTerm+dslify syn i = transform dslifyApp + where+ dslifyApp (PApp fc (PRef _ f) [a])+ | [d] <- lookupCtxt f (idris_dsls i)+ = desugar (syn { dsl_info = d }) i (getTm a)+ dslifyApp t = t+ desugar :: SyntaxInfo -> IState -> PTerm -> PTerm-desugar syn i t = let t' = expandDo (dsl_info syn) t in- t' -- addImpl i t'+desugar syn i t = let t' = expandDo (dsl_info syn) t+ in dslify syn i t' +mkTTName :: FC -> Name -> PTerm+mkTTName fc n =+ let mkList fc [] = PRef fc (sNS (sUN "Nil") ["List", "Prelude"])+ 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+ reflm n = sNS (sUN n) ["Reflection", "Language"]+ in case n of+ UN nm -> PApp fc (PRef fc (reflm "UN")) [ pexp (stringC nm)]+ NS nm ns -> PApp fc (PRef fc (reflm "NS")) [ pexp (mkTTName fc nm)+ , pexp (mkList fc ns)]+ MN i nm -> PApp fc (PRef fc (reflm "MN")) [ pexp (intC i)+ , pexp (stringC nm)]+ otherwise -> PRef fc $ reflm "NErased"+ expandDo :: DSL -> PTerm -> PTerm expandDo dsl (PLam fc n ty tm) | Just lam <- dsl_lambda dsl- = let sc = PApp fc lam [pexp (var dsl n tm 0)] in- expandDo dsl sc+ = 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) | Just letb <- dsl_let dsl- = let sc = PApp (fileFC "(dsl)") letb [pexp v, pexp (var dsl n tm 0)] in- expandDo dsl sc+ = 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) | Just pi <- dsl_pi dsl- = let sc = PApp (fileFC "(dsl)") pi [pexp ty, pexp (var dsl n tm 0)] in- expandDo dsl sc+ = 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)@@ -76,8 +108,10 @@ 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 +-- | Replace DSL-bound variable in a term var :: DSL -> Name -> PTerm -> Int -> PTerm var dsl n t i = v' i t where v' i (PRef fc x) | x == n =@@ -111,11 +145,15 @@ mkVar fc 0 = case index_first dsl of Nothing -> PElabError (Msg "No index_first defined")- Just f -> f+ Just f -> setFC fc f mkVar fc n = case index_next dsl of Nothing -> PElabError (Msg "No index_next defined") Just f -> PApp fc f [pexp (mkVar fc (n-1))] + setFC fc (PRef _ n) = PRef fc n+ setFC fc (PApp _ f xs) = PApp fc (setFC fc f) (map (fmap (setFC fc)) xs)+ setFC fc t = t+ unIdiom :: PTerm -> PTerm -> FC -> PTerm -> PTerm unIdiom ap pure fc e@(PApp _ _ _) = let f = getFn e in mkap (getFn e)@@ -157,6 +195,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' t = return t dbArg a = do t' <- db' (getTm a)
src/Idris/DeepSeq.hs view
@@ -149,21 +149,24 @@ 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)+ rnf (PClass x1 x2 x3 x4 x5 x6 x8 x7 x9) = 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 (PInstance x1 x2 x3 x4 x5 x6 x7 x8)+ 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 x1 `seq` rnf x2 `seq` rnf x3 `seq`- rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` ()+ rnf x4 `seq`+ rnf x5 `seq`+ rnf x6 `seq`+ rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `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` () rnf (PDirective x1) = ()- rnf (PProvider x1 x2 x3 x4)- = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+ rnf (PProvider x1 x2 x3 x4 x5)+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` () rnf (PTransform x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () @@ -178,13 +181,13 @@ rnf (PClause x1 x2 x3 x4 x5 x6) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()- rnf (PWith x1 x2 x3 x4 x5 x6)+ rnf (PWith 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 (PClauseR x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()- rnf (PWithR x1 x2 x3 x4)- = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+ rnf (PWithR x1 x2 x3 x4 x5)+ = 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)@@ -202,6 +205,7 @@ rnf (PLet _ x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `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` ()@@ -238,6 +242,7 @@ 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` () instance (NFData t) => NFData (PTactic' t) where rnf (Intro x1) = rnf x1 `seq` ()@@ -249,6 +254,7 @@ rnf (Induction x1) = rnf x1 `seq` () rnf (CaseTac x1) = rnf x1 `seq` () rnf (Equiv x1) = rnf x1 `seq` ()+ rnf (Claim x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (MatchRefine x1) = rnf x1 `seq` () rnf (LetTac x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (LetTacTy x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()@@ -279,6 +285,7 @@ rnf Skip = () rnf (TFail x1) = rnf x1 `seq` () rnf SourceFC = ()+ rnf Unfocus = () instance NFData ErrorReportPart where rnf (TermPart x1) = rnf x1 `seq` ()@@ -306,9 +313,9 @@ rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` () instance NFData ClassInfo where- rnf (CI x1 x2 x3 x4 x5 x6)+ rnf (CI 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` () instance NFData OptInfo where rnf (Optimise x1 x2)@@ -346,13 +353,10 @@ rnf (UConstraint x1 x2) = rnf x1 `seq` rnf x2 `seq` () instance NFData SyntaxInfo where- rnf (Syn x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)+ rnf (Syn 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 x10 `seq` rnf x11 `seq` ()---+ rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` ()
src/Idris/Delaborate.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-}-module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', fancifyAnnots, pprintDelab, pprintDelabTy, pprintErr) where+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+module Idris.Delaborate (annName, bugaddr, delab, delab', delabMV, delabTy, delabTy', fancifyAnnots, pprintDelab, pprintDelabTy, pprintErr) where -- Convert core TT back into high level syntax, primarily for display -- purposes.@@ -32,6 +33,7 @@ (ty:_) -> case lookupCtxt n (idris_implicits i) of (imps:_) -> delabTy' i imps ty False False _ -> delabTy' i [] ty False False+ [] -> error "delabTy: got non-existing name" delab' :: IState -> Term -> Bool -> Bool -> PTerm delab' i t f mvs = delabTy' i [] t f mvs@@ -86,6 +88,7 @@ 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 _ (Proj _ _) = error "Delaboration got run-time-only Proj!" de env _ Erased = Placeholder de env _ Impossible = Placeholder de env _ (TType i) = PType@@ -183,6 +186,7 @@ case lookupCtxt n (idris_implicits i) of (imps:_) -> delabTy' i imps ty False False _ -> delabTy' i [] ty False False+ [] -> error "pprintDelabTy got a name that doesn't exist" pprintTerm :: IState -> PTerm -> Doc OutputAnnotation pprintTerm ist = pprintTerm' ist []@@ -190,6 +194,20 @@ pprintTerm' :: IState -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation pprintTerm' ist bnd tm = pprintPTerm (ppOptionIst ist) bnd [] (idris_infixes ist) tm +pprintProv :: IState -> [(Name, Term)] -> Provenance -> Doc OutputAnnotation+pprintProv i e ExpectedType = text "Expected type"+pprintProv i e InferredVal = text "Inferred value"+pprintProv i e GivenVal = text "Given value"+pprintProv i e (SourceTerm tm) + = text "Type of " <> + annotate (AnnTerm (zip (map fst e) (repeat False)) tm)+ (pprintTerm' i (zip (map fst e) (repeat False)) (delab i tm))+pprintProv i e (TooManyArgs tm) + = text "Is " <> + annotate (AnnTerm (zip (map fst e) (repeat False)) tm)+ (pprintTerm' i (zip (map fst e) (repeat False)) (delab i tm))+ <> text " applied to too many arguments?"+ pprintErr :: IState -> Err -> Doc OutputAnnotation pprintErr i err = pprintErr' i (fmap (errReverse i) err) @@ -199,20 +217,28 @@ text "This is probably a bug, or a missing error message.", text ("Please consider reporting at " ++ bugaddr) ]-pprintErr' i (CantUnify _ x_in y_in e sc s) =+pprintErr' i (CantUnify _ (x_in, xprov) (y_in, yprov) e sc s) = let (x_ns, y_ns, nms) = renameMNs x_in y_in (x, y) = addImplicitDiffs (delab i x_ns) (delab i y_ns) in text "Can't unify" <> indented (annTm x_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) sc- ++ zip nms (repeat False)) x)) <$>+ ++ zip nms (repeat False)) x)) + <> case xprov of+ Nothing -> empty+ Just t -> text " (" <> pprintProv i sc t <> text ")"+ <$> text "with" <> indented (annTm y_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) sc- ++ zip nms (repeat False)) y)) <>+ ++ zip nms (repeat False)) y)) + <> case yprov of+ Nothing -> empty+ Just t -> text " (" <> pprintProv i sc t <> text ")"+ <> case e of Msg "" -> empty -- if the specific error is the same as the one we just printed, -- there's no need to print it- CantUnify _ x_in' y_in' _ _ _ | x_in == x_in' && y_in == y_in' -> empty+ CantUnify _ (x_in', _) (y_in',_) _ _ _ | x_in == x_in' && y_in == y_in' -> empty _ -> line <> line <> text "Specifically:" <> indented (pprintErr' i e) <> if (opt_errContext (idris_options i)) then showSc i sc else empty@@ -263,7 +289,11 @@ text "Can't verify injectivity of" <+> annTm p (pprintTerm i (delab i p)) <+> text " when unifying" <+> annTm x (pprintTerm i (delab i x)) <+> text "and" <+> annTm y (pprintTerm i (delab i y))-pprintErr' i (CantResolve c) = text "Can't resolve type class" <+> pprintTerm i (delab i c)+pprintErr' i (CantResolve _ c) = text "Can't resolve type class" <+> pprintTerm i (delab i c)+pprintErr' i (InvalidTCArg n t) + = annTm t (pprintTerm i (delab i t)) <+> text " cannot be a parameter of "+ <> 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))) pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n@@ -273,6 +303,12 @@ pprintErr' i (CantMatch t) = text "Can't match on" <+> annTm t (pprintTerm i (delab i t)) pprintErr' i (IncompleteTerm t) = text "Incomplete term" <+> annTm t (pprintTerm i (delab i t))+pprintErr' i (NoEliminator s t)+ = text "No " <> text s <> text " for type " <+>+ annTm t (pprintTerm i (delab i t)) <$>+ 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 (UniqueError NullType n) = text "Borrowed name" <+> annName' n (showbasic n)@@ -308,7 +344,7 @@ where whatIsName = let ctxt = tt_ctxt i in if isTConName f ctxt then text "type constructor" <> space- else if isConName f ctxt+ else if isDConName f ctxt then text "constructor" <> space else if isFnName f ctxt then text "function" <> space@@ -335,10 +371,30 @@ 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) =+ text "Elaboration halted." <>+ maybe empty (indented . text) msg <> line <>+ text "Term: " <> indented (pprintTT [] tm) <> line <>+ text "Holes:" <>+ indented (vsep (map ppHole holes)) --- Make sure the machine invented names are shown helpfully to the user, so--- that any names which differ internally also differ visibly+ where ppHole :: (Name, Type, Env) -> Doc OutputAnnotation+ ppHole (hn, goal, env) =+ ppAssumptions [] (reverse env) <>+ text "----------------------------------" <> line <>+ bindingOf hn False <+> text ":" <+>+ pprintTT (map fst (reverse env)) goal <> line+ ppAssumptions :: [Name] -> Env -> Doc OutputAnnotation+ ppAssumptions ns [] = empty+ ppAssumptions ns ((n, b) : rest) =+ bindingOf n False <+>+ text ":" <+>+ pprintTT ns (binderTy b) <>+ line <>+ ppAssumptions (n:ns) rest +-- | Make sure the machine invented names are shown helpfully to the user, so+-- that any names which differ internally also differ visibly renameMNs :: Term -> Term -> (Term, Term, [Name]) renameMNs x y = let ns = nub $ allTTNames x ++ allTTNames y newnames = evalState (getRenames [] ns) 1 in@@ -488,7 +544,7 @@ _ | isTConName n ctxt -> AnnName n (Just TypeOutput) docs ty _ | isMetavarName n ist -> AnnName n (Just MetavarOutput) docs ty _ | isPostulateName n ist -> AnnName n (Just PostulateOutput) docs ty- _ | otherwise -> annot+ _ | otherwise -> annot where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs docOverview ist n = do docs <- lookupCtxtExact n (idris_docstrings ist) let o = overview (fst docs)
src/Idris/Docs.hs view
@@ -1,15 +1,18 @@-{-# LANGUAGE PatternGuards #-}-module Idris.Docs (pprintDocs, getDocs, pprintConstDocs, FunDoc(..), Docs (..)) where+{-# LANGUAGE DeriveFunctor, PatternGuards, MultiWayIf #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+module Idris.Docs (pprintDocs, getDocs, pprintConstDocs, FunDoc, FunDoc'(..), Docs, Docs'(..)) where import Idris.AbsSyntax import Idris.AbsSyntaxTree import Idris.Delaborate import Idris.Core.TT import Idris.Core.Evaluate-import Idris.Docstrings (Docstring, emptyDocstring, noDocs, nullDocstring, renderDocstring, DocTerm, renderDocTerm)+import Idris.Docstrings (Docstring, emptyDocstring, noDocs, nullDocstring, renderDocstring, DocTerm, renderDocTerm, overview) import Util.Pretty +import Control.Arrow (first)+ import Data.Maybe import Data.List import qualified Data.Text as T@@ -18,22 +21,30 @@ -- -- Issue #1573 on the Issue tracker. -- https://github.com/idris-lang/Idris-dev/issues/1573-data FunDoc = FD Name (Docstring DocTerm)- [(Name, PTerm, Plicity, Maybe (Docstring DocTerm))] -- args: name, ty, implicit, docs- PTerm -- function type- (Maybe Fixity)+data FunDoc' d = FD Name d+ [(Name, PTerm, Plicity, Maybe d)] -- args: name, ty, implicit, docs+ PTerm -- function type+ (Maybe Fixity)+ deriving Functor -data Docs = FunDoc FunDoc- | DataDoc FunDoc -- type constructor docs- [FunDoc] -- data constructor docs- | ClassDoc Name (Docstring DocTerm)-- class docs- [FunDoc] -- method docs- [(Name, Maybe (Docstring DocTerm))] -- parameters and their docstrings- [PTerm] -- instances- [PTerm] -- superclasses- | ModDoc [String] -- Module name- (Docstring DocTerm)+type FunDoc = FunDoc' (Docstring DocTerm) +data Docs' d = FunDoc (FunDoc' d)+ | DataDoc (FunDoc' d) -- type constructor docs+ [FunDoc' d] -- data constructor docs+ | ClassDoc Name d -- class docs+ [FunDoc' d] -- method docs+ [(Name, Maybe d)] -- parameters and their docstrings+ [(Maybe Name, PTerm, (d, [(Name, d)]))] -- instances: name for named instances, the constraint term, the docs+ [PTerm] -- subclasses+ [PTerm] -- superclasses+ | NamedInstanceDoc Name (FunDoc' d) -- name is class+ | ModDoc [String] -- Module name+ d+ deriving Functor++type Docs = Docs' (Docstring DocTerm)+ showDoc ist d | nullDocstring d = empty | otherwise = text " -- " <>@@ -82,7 +93,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 superclasses)+pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses) = nest 4 (text "Type class" <+> prettyName True (ppopt_impl ppo) [] n <> if nullDocstring doc then empty@@ -94,9 +105,13 @@ vsep (map (pprintFD ist) meths)) <$> nest 4 (text "Instances:" <$>- vsep (if null instances' then [text "<no instances>"]- else map dumpInstance instances'))+ vsep (if null instances then [text "<no instances>"]+ else map pprintInstance normalInstances)) <>+ (if null namedInstances then empty+ else line <$> nest 4 (text "Named instances:" <$>+ vsep (map pprintInstance namedInstances)))+ <> (if null subclasses then empty else line <$> nest 4 (text "Subclasses:" <$> vsep (map (dumpInstance . prettifySubclasses) subclasses)))@@ -106,12 +121,43 @@ vsep (map dumpInstance superclasses))) where params' = zip pNames (repeat False)+ + (normalInstances, namedInstances) = partition (\(n, _, _) -> not $ isJust n)+ instances pNames = map fst params ppo = ppOptionIst ist infixes = idris_infixes ist + pprintInstance (mname, term, (doc, argDocs)) =+ nest 4 (iname mname <> dumpInstance term <>+ (if nullDocstring doc+ then empty+ else line <>+ renderDocstring+ (renderDocTerm+ (pprintDelab ist)+ (normaliseAll (tt_ctxt ist) []))+ doc) <>+ if null argDocs+ then empty+ else line <> vsep (map (prettyInstanceParam (map fst argDocs)) argDocs))+++ iname Nothing = empty+ iname (Just n) = annName n <+> colon <> space++ prettyInstanceParam params (name, doc) =+ if nullDocstring doc+ then empty+ else prettyName True False (zip params (repeat False)) name <+>+ showDoc ist doc++-- if any (isJust . snd) params+-- then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty (showDoc ist) md) params)+-- else hsep (punctuate comma (map (prettyName True False params' . fst) params))+ dumpInstance :: PTerm -> Doc OutputAnnotation dumpInstance = pprintPTerm ppo params' [] infixes @@ -134,33 +180,51 @@ isSubclass (PPi _ _ _ pt) = isSubclass pt isSubclass _ = False - (subclasses, instances') = partition isSubclass instances+ prettyParameters =+ if any (isJust . snd) params+ then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty (showDoc ist) md) params)+ else hsep (punctuate comma (map (prettyName True False params' . fst) params)) - prettyParameters = if any (isJust . snd) params- then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty (showDoc ist) md) params)- else hsep (punctuate comma (map (prettyName True False params' . fst) params))+pprintDocs ist (NamedInstanceDoc _cls doc)+ = nest 4 (text "Named instance:" <$> pprintFD ist doc) pprintDocs ist (ModDoc mod docs) = nest 4 $ text "Module" <+> text (concat (intersperse "." mod)) <> colon <$> renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) docs +-- | Determine a truncation function depending how much docs the user+-- wants to see+howMuch FullDocs = id+howMuch OverviewDocs = overview+ -- | Given a fully-qualified, disambiguated name, construct the -- documentation object for it-getDocs :: Name -> Idris Docs-getDocs n@(NS n' ns) | n' == modDocName+getDocs :: Name -> HowMuchDocs -> Idris Docs+getDocs n@(NS n' ns) w | n' == modDocName = do i <- getIState case lookupCtxtExact n (idris_moduledocs i) of- Just doc -> return $ ModDoc (reverse (map T.unpack ns)) doc+ Just doc -> return . ModDoc (reverse (map T.unpack ns)) $ howMuch w doc Nothing -> fail $ "Module docs for " ++ show (reverse (map T.unpack ns)) ++ " do not exist! This shouldn't have happened and is a bug."-getDocs n+getDocs n w = do i <- getIState- case lookupCtxt n (idris_classes i) of- [ci] -> docClass n ci- _ -> case lookupCtxt n (idris_datatypes i) of- [ti] -> docData n ti- _ -> do fd <- docFun n- return (FunDoc fd)+ docs <- if | Just ci <- lookupCtxtExact n (idris_classes i)+ -> docClass n ci+ | Just ti <- lookupCtxtExact n (idris_datatypes i)+ -> docData n ti+ | Just class_ <- classNameForInst i n+ -> do fd <- docFun n+ return $ NamedInstanceDoc class_ fd+ | otherwise+ -> do fd <- docFun n+ return (FunDoc fd)+ return $ fmap (howMuch w) docs+ where classNameForInst :: IState -> Name -> Maybe Name+ classNameForInst ist n =+ listToMaybe [ cn+ | (cn, ci) <- toAlist (idris_classes ist)+ , n `elem` class_instances ci+ ] docData :: Name -> TypeInfo -> Idris Docs docData n ti@@ -173,15 +237,36 @@ = do i <- getIState let docStrings = listToMaybe $ lookupCtxt n $ idris_docstrings i docstr = maybe emptyDocstring fst docStrings- params = map (\pn -> (pn, docStrings >>= (lookup pn . snd))) (class_params ci)- instances = map (delabTy i) (class_instances ci)+ params = map (\pn -> (pn, docStrings >>= (lookup pn . snd)))+ (class_params ci)+ docsForInstance inst = fromMaybe (emptyDocstring, []) .+ flip lookupCtxtExact (idris_docstrings i) $+ inst+ instances = map (\inst -> (namedInst inst,+ delabTy i inst,+ docsForInstance inst))+ (nub (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)- return $ ClassDoc n docstr mdocs params instances superclasses+ return $ ClassDoc+ n docstr mdocs params+ instances' (map (\(_,tm,_) -> tm) subclasses) superclasses where- getDInst (PInstance _ _ _ _ _ t _ _) = Just t+ namedInst (NS n ns) = fmap (flip NS ns) (namedInst n)+ namedInst n@(UN _) = Just n+ namedInst _ = Nothing+ + getDInst (PInstance _ _ _ _ _ _ _ t _ _) = Just t getDInst _ = Nothing + isSubclass (PPi (Constraint _ _) _ (PApp _ _ args) (PApp _ (PRef _ nm) args'))+ = nm == n && map getTm args == map getTm args'+ isSubclass (PPi _ _ _ pt)+ = isSubclass pt+ isSubclass _+ = False+ docFun :: Name -> Idris FunDoc docFun n = do i <- getIState@@ -200,6 +285,7 @@ where funName :: Name -> String funName (UN n) = str n funName (NS n _) = funName n+ funName n = show n getPArgNames :: PTerm -> [(Name, Docstring DocTerm)] -> [(Name, PTerm, Plicity, Maybe (Docstring DocTerm))] getPArgNames (PPi plicity name ty body) ds =
src/Idris/Elab/Class.hs view
@@ -50,12 +50,13 @@ import Util.Pretty(pretty, text) -data MArgTy = IA | EA | CA deriving Show+data MArgTy = IA Name | EA Name | CA deriving Show elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> FC -> [(Name, PTerm)] ->- Name -> [(Name, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [PDecl] -> Idris ()-elabClass info syn_in doc fc constraints tn ps pDocs ds+ 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 let constraint = PApp fc (PRef fc tn)@@ -68,33 +69,37 @@ let idecls = filter instdecl ds -- default superclass instance declarations mapM_ checkDefaultSuperclassInstance idecls let mnames = map getMName mdecls- logLvl 2 $ "Building methods " ++ show mnames+ logLvl 1 $ "Building methods " ++ show mnames ims <- mapM (tdecl mnames) mdecls defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint) (filter clause ds) let (methods, imethods) = unzip (map (\ ( x,y,z) -> (x, y)) ims) let defaults = map (\ (x, (y, z)) -> (x,y)) defs- addClass tn (CI cn (map nodoc imethods) defaults idecls (map fst ps) []) -- build instance constructor type- -- decorate names of functions to ensure they can't be referred- -- to elsewhere in the class declaration let cty = impbind ps $ conbind constraints $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods) constraint let cons = [(emptyDocstring, [], cn, cty, fc, [])] let ddecl = PDatadecl tn tty cons logLvl 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)- elabData info (syn { no_imp = no_imp syn ++ mnames }) doc pDocs fc [] 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)+ -- for each constraint, build a top level function to chase it- logLvl 5 $ "Building functions"--- let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps--- ++ using syn }- fns <- mapM (cfun cn constraint syn (map fst imethods)) constraints- mapM_ (rec_elabDecl info EAll info) (concat fns)+ cfns <- mapM (cfun cn constraint syn (map fst imethods)) constraints+ mapM_ (rec_elabDecl info EAll info) (concat cfns)+ -- for each method, build a top level function- fns <- mapM (tfun cn constraint syn (map fst imethods)) imethods+ fns <- mapM (tfun cn constraint (syn { imp_methods = mnames })+ (map fst imethods)) imethods+ logLvl 5 $ "Functions " ++ show fns+ -- Elaborate the the top level methods mapM_ (rec_elabDecl info EAll info) (concat fns)+ -- add the default definitions mapM_ (rec_elabDecl info EAll info) (concat (map (snd.snd) defs)) addIBC (IBCClass tn)@@ -109,8 +114,8 @@ mdec x = x -- TODO: probably should normalise- checkDefaultSuperclassInstance :: PDecl -> Idris () - checkDefaultSuperclassInstance (PInstance _ fc cs n ps _ _ _)+ checkDefaultSuperclassInstance :: PDecl -> Idris ()+ 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@@ -120,20 +125,20 @@ $ tfail (At fc (Msg $ "Default instances must be for a superclass constraint on the containing class.")) return () - impbind :: [(Name, PTerm)] -> PTerm -> PTerm + impbind :: [(Name, PTerm)] -> PTerm -> PTerm impbind [] x = x impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x) - conbind :: [(Name, PTerm)] -> PTerm -> PTerm + conbind :: [(Name, PTerm)] -> PTerm -> PTerm conbind ((c, ty) : ns) x = PPi constraint c 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 allmeths n t- logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t'+ = do t' <- implicit' info syn (map fst 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) + (n, (doc, o, (toExp (map fst ps) (\ l s p -> Imp l s p Nothing) t'))), (n, (syn, o, t) ) ) tdecl _ _ = ifail "Not allowed in a class declaration"@@ -155,7 +160,7 @@ tydecl (PTy _ _ _ _ _ _ _) = True tydecl _ = False- instdecl (PInstance _ _ _ _ _ _ _ _) = True+ instdecl (PInstance _ _ _ _ _ _ _ _ _ _) = True instdecl _ = False clause (PClauses _ _ _ _) = True clause _ = False@@ -195,33 +200,33 @@ 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)+ iLOG (showTmImpls ty') iLOG (show (m, ty', capp, margs)) iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs) return [PTy doc [] syn fc o m ty', PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]] - getMArgs (PPi (Imp _ _ _ _) n ty sc) = IA : getMArgs sc- getMArgs (PPi (Exp _ _ _) n ty sc) = EA : 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 | otherwise = getMeth ms as x - lhsArgs (EA : xs) (n : ns) = [] -- pexp (PRef fc n) : lhsArgs xs ns- lhsArgs (IA : xs) ns = lhsArgs xs ns+ lhsArgs (EA _ : xs) (n : ns) = [] -- pexp (PRef fc n) : lhsArgs xs ns+ lhsArgs (IA n : xs) ns = pimp n (PRef fc n) False : lhsArgs xs ns lhsArgs (CA : xs) ns = lhsArgs xs ns lhsArgs [] _ = [] - rhsArgs (EA : xs) (n : ns) = [] -- pexp (PRef fc n) : rhsArgs xs ns- rhsArgs (IA : xs) ns = pexp Placeholder : rhsArgs xs ns+ rhsArgs (EA _ : xs) (n : ns) = [] -- pexp (PRef fc n) : rhsArgs xs ns+ rhsArgs (IA n : xs) ns = pexp (PRef fc n) : rhsArgs xs ns 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 sc = PPi (constraint { pstatic = Static }) + insertConstraint c sc = PPi (constraint { pstatic = Static }) (sMN 0 "class") c sc -- make arguments explicit and don't bind class parameters@@ -230,5 +235,17 @@ | 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) toExp ns e sc = sc++findDets :: Name -> [Name] -> Idris [Int]+findDets n ns = + do i <- getIState+ return $ case lookupTyExact n (tt_ctxt i) of+ Just ty -> getDetPos 0 ns ty+ Nothing -> []+ where+ getDetPos i ns (Bind n (Pi _ _ _) sc)+ | n `elem` ns = i : getDetPos (i + 1) ns sc+ | otherwise = getDetPos (i + 1) ns sc+ getDetPos _ _ _ = []
src/Idris/Elab/Clause.hs view
@@ -222,7 +222,7 @@ let opt = idris_optimisation ist putIState (ist { idris_patdefs = addDef n (force pdef_pe, force pmissing) (idris_patdefs ist) })- let caseInfo = CaseInfo (inlinable opts) (dictionary opts)+ let caseInfo = CaseInfo (inlinable opts) (inlinable opts) (dictionary opts) case lookupTy n ctxt of [ty] -> do updateContext (addCasedef n erInfo caseInfo tcase defaultcase@@ -408,6 +408,7 @@ _ -> True concreteTm ist (Constant _) = True concreteTm ist (Bind n (Lam _) sc) = True+ concreteTm ist (Bind n (Pi _ _ _) sc) = True concreteTm ist (Bind n (Let _ _) sc) = concreteTm ist sc concreteTm ist _ = False @@ -454,8 +455,10 @@ -- if the LHS type checks, it is possible case elaborate ctxt (sMN 0 "patLHS") infP initEState (erun fc (buildTC i info ELHS [] fname (infTerm lhs))) of- OK ((lhs', _, _), _) ->- do let lhs_tm = orderPats (getInferTerm lhs')+ OK (ElabResult lhs' _ _ ctxt' newDecls, _) ->+ do setContext ctxt'+ processTacticDecls newDecls+ let lhs_tm = orderPats (getInferTerm lhs') case recheck ctxt [] (forget lhs_tm) lhs_tm of OK _ -> return True err -> return False@@ -463,7 +466,7 @@ Error err -> if tcgen then return (recoverable ctxt err) else return (validCase ctxt err || recoverable ctxt err)- where validCase ctxt (CantUnify _ topx topy e _ _)+ 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))@@ -473,7 +476,7 @@ validCase ctxt (ElaboratingArg _ _ _ e) = validCase ctxt e validCase ctxt _ = True - recoverable ctxt (CantUnify r topx topy e _ _)+ recoverable ctxt (CantUnify r (topx, _) (topy, _) e _ _) = let topx' = normalise ctxt [] topx topy' = normalise ctxt [] topy in checkRec topx' topy'@@ -545,7 +548,7 @@ elabClause info opts (_, PClause fc fname lhs_in [] PImpossible []) = do let tcgen = Dictionary `elem` opts i <- get- let lhs = addImpl i lhs_in+ let lhs = addImpl [] i lhs_in b <- checkPossible info fc tcgen fname lhs_in case b of True -> tclift $ tfail (At fc@@ -578,14 +581,15 @@ logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++ "\n" ++ show (fn_ty, fn_is)) - (((lhs', dlhs, []), probs, inj), _) <-- tclift $ elaborate ctxt (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))-+ ((ElabResult lhs' dlhs [] ctxt' newDecls, probs, inj), _) <-+ tclift $ elaborate ctxt (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 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs) let lhs_tm = orderPats (getInferTerm lhs')@@ -599,7 +603,7 @@ -- If we're inferring metavariables in the type, don't recheck, -- because we're only doing this to try to work out those metavariables (clhs_c, clhsty) <- if not inf- then recheckC fc [] lhs_tm+ then recheckC fc id [] lhs_tm else return (lhs_tm, lhs_ty) let clhs = normalise ctxt [] clhs_c let borrowed = borrowedNames [] clhs@@ -647,18 +651,19 @@ -- Now build the RHS, using the type of the LHS as the goal. i <- getIState -- new implicits from where block logLvl 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))- let rhs = addImplBoundInf i (map fst newargs) (defs \\ decls)+ let rhs = addImplBoundInf i (map fst newargs_all) (defs \\ decls) (expandParams decorate newargs defs (defs \\ decls) rhs_in)- logLvl 2 $ "RHS: " ++ showTmImpls rhs+ 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), _) <-+ ((rhs', defer, is, probs, ctxt', newDecls), _) <- tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty initEState (do pbinds ist lhs_tm mapM_ setinj (nub (params ++ inj)) setNextName- (_, _, is) <- errAt "right hand side of " fname- (erun fc (build i winfo ERHS opts fname rhs))+ (ElabResult _ _ is ctxt' newDecls) <- + 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@@ -667,15 +672,16 @@ tt <- get_term let (tm, ds) = runState (collectDeferred (Just fname) tt) [] probs <- get_probs- return (tm, ds, is, probs))-+ return (tm, ds, is, probs, ctxt', newDecls))+ setContext ctxt'+ processTacticDecls newDecls when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs) logLvl 5 "DONE CHECK"- logLvl 2 $ "---> " ++ show rhs'+ logLvl 4 $ "---> " ++ show rhs' when (not (null defer)) $ iLOG $ "DEFERRED " ++ show (map (\ (n, (_,_,t)) -> (n, t)) defer)- def' <- checkDef fc defer+ def' <- checkDef fc (Elaborating "deferred type of ") defer let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def' addDeferred def'' mapM_ (\(n, _) -> addIBC (IBCDef n)) def''@@ -694,7 +700,7 @@ logLvl 6 $ " ==> " ++ show (forget rhs') (crhs, crhsty) <- if not inf- then recheckC_borrowing True borrowed fc [] rhs'+ then recheckC_borrowing True borrowed fc id [] rhs' else return (rhs', clhsty) logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty ctxt <- getContext@@ -703,7 +709,7 @@ OK (_, cs) -> do addConstraints fc cs logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs return ()- Error e -> ierror (At fc (CantUnify False clhsty crhsty e [] 0))+ Error e -> ierror (At fc (CantUnify False (clhsty, Nothing) (crhsty, Nothing) e [] 0)) i <- getIState checkInferred fc (delab' i crhs True True) rhs -- if the function is declared '%error_reverse', or its type,@@ -795,7 +801,7 @@ isArg' _ = False isArg _ _ = False -elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)+elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock) = do let tcgen = Dictionary `elem` opts ctxt <- getContext -- Build the LHS as an "Infer", and pull out its type and@@ -811,38 +817,42 @@ 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)- ((lhs', dlhs, []), _) <-+ (ElabResult lhs' dlhs [] ctxt' newDecls, _) <- tclift $ elaborate ctxt (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 let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs' let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty)) let static_names = getStaticNames i lhs_tm logLvl 5 (show lhs_tm ++ "\n" ++ show static_names)- (clhs, clhsty) <- recheckC fc [] lhs_tm+ (clhs, clhsty) <- recheckC fc id [] lhs_tm logLvl 5 ("Checked " ++ show clhs) let bargs = getPBtys (explicitNames (normalise ctxt [] lhs_tm)) let wval = addImplBound i (map fst bargs) wval_in logLvl 5 ("Checking " ++ showTmImpls wval) -- Elaborate wval in this context- ((wval', defer, is), _) <-+ ((wval', defer, is, ctxt', newDecls), _) <- tclift $ elaborate ctxt (sMN 0 "withRHS") (bindTyArgs PVTy bargs infP) initEState (do pbinds i lhs_tm setNextName -- TODO: may want where here - see winfo abpve- (_', d, is) <- errAt "with value in " fname+ (ElabResult _ d is ctxt' newDecls) <- 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))- def' <- checkDef fc defer+ return (tt, d, is, ctxt', newDecls))+ setContext ctxt'+ processTacticDecls newDecls+ def' <- checkDef fc iderr defer let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def' addDeferred def'' mapM_ (elabCaseBlock info opts) is logLvl 5 ("Checked wval " ++ show wval')- (cwval, cwvalty) <- recheckC fc [] (getInferTerm wval')+ (cwval, cwvalty) <- recheckC fc id [] (getInferTerm wval') let cwvaltyN = explicitNames (normalise ctxt [] cwvalty) let cwvalN = explicitNames (normalise ctxt [] cwval) logLvl 3 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty)@@ -858,6 +868,11 @@ -- rather than a de Bruijn index. let pdeps = usedNamesIn pvars i (delab i cwvalty) let (bargs_pre, bargs_post) = split pdeps bargs []++ let mpn = case pn_in of+ Nothing -> Nothing+ Just n -> Just (uniqueName n (map fst bargs))+ logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++ " depends on " ++ show pdeps ++ " from " ++ show pvars) logLvl 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post)@@ -866,12 +881,19 @@ -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty let wargval = getRetTy cwvalN let wargtype = getRetTy cwvaltyN+ let wargname = sMN windex "warg"+ logLvl 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype) let wtype = bindTyArgs (flip (Pi Nothing) (TType (UVar 0))) (bargs_pre ++- (sMN 0 "warg", wargtype) :- map (abstract (sMN 0 "warg") wargval wargtype) bargs_post)- (substTerm wargval (P Bound (sMN 0 "warg") wargtype) ret_ty)- logLvl 5 ("New function type " ++ show wtype)+ (wargname, wargtype) :+ map (abstract wargname wargval wargtype) bargs_post +++ case mpn of+ Just pn -> [(pn, mkApp (P Ref eqTy Erased)+ [wargtype, wargtype,+ P Bound wargname Erased, wargval])]+ Nothing -> [])+ (substTerm wargval (P Bound wargname wargtype) ret_ty)+ logLvl 3 ("New function type " ++ show wtype) let wname = SN (WithN windex fname) let imps = getImps wtype -- add to implicits context@@ -885,54 +907,60 @@ addIBC (IBCImp wname) addIBC (IBCStatic wname) - def' <- checkDef fc [(wname, (-1, Nothing, wtype))]+ def' <- checkDef fc iderr [(wname, (-1, Nothing, wtype))] let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def' addDeferred def'' -- in the subdecls, lhs becomes: -- fname pats | wpat [rest] -- ==> fname' ps wpat [rest], match pats against toplevel for ps- wb <- mapM (mkAuxC wname lhs (map fst bargs_pre) (map fst bargs_post))+ wb <- mapM (mkAuxC mpn wname lhs (map fst bargs_pre) (map fst bargs_post)) withblock logLvl 3 ("with block " ++ show wb) -- propagate totality assertion to the new definitions when (AssertTotal `elem` opts) $ setFlags wname [AssertTotal] mapM_ (rec_elabDecl info EAll info) wb - -- rhs becomes: fname' ps wval+ -- rhs becomes: fname' ps_pre wval ps_post Refl let rhs = PApp fc (PRef fc wname) (map (pexp . (PRef fc) . fst) bargs_pre ++ pexp wval :- (map (pexp . (PRef fc) . fst) bargs_post))+ (map (pexp . (PRef fc) . fst) bargs_post) +++ case mpn of+ Nothing -> []+ Just _ -> [pexp (PRefl fc Placeholder)]) logLvl 5 ("New RHS " ++ showTmImpls rhs) ctxt <- getContext -- New context with block added i <- getIState- ((rhs', defer, is), _) <-+ ((rhs', defer, is, ctxt', newDecls), _) <- tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty initEState (do pbinds i lhs_tm setNextName- (_, d, is) <- erun fc (build i info ERHS opts fname rhs)+ (ElabResult _ d is ctxt' newDecls) <- erun fc (build i info ERHS opts fname rhs) psolve lhs_tm tt <- get_term- return (tt, d, is))- def' <- checkDef fc defer+ return (tt, d, is, ctxt', newDecls))+ setContext ctxt'+ processTacticDecls newDecls++ def' <- checkDef fc iderr defer let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def' addDeferred def'' mapM_ (elabCaseBlock info opts) is logLvl 5 ("Checked RHS " ++ show rhs')- (crhs, crhsty) <- recheckC fc [] rhs'+ (crhs, crhsty) <- recheckC fc id [] rhs' return $ (Right (clhs, crhs), lhs) where getImps (Bind n (Pi _ _ _) t) = pexp Placeholder : getImps t getImps _ = [] - mkAuxC wname lhs ns ns' (PClauses fc o n cs)- | True = do cs' <- mapM (mkAux wname lhs ns ns') cs+ mkAuxC pn wname lhs ns ns' (PClauses fc o n cs)+ | True = do cs' <- mapM (mkAux pn wname lhs ns ns') cs return $ PClauses fc o wname cs' | otherwise = ifail $ show fc ++ "with clause uses wrong function name " ++ show n- mkAuxC wname lhs ns ns' d = return $ d+ mkAuxC pn wname lhs ns ns' d = return $ d - mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)+ mkAux pn wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres) = do i <- getIState let tm = addImplPat i tm_in logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " ++@@ -941,33 +969,36 @@ Left (a,b) -> ifail $ show fc ++ ":with clause does not match top level" Right mvars -> do logLvl 3 ("Match vars : " ++ show mvars)- lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w+ lhs <- updateLHS n pn wname mvars ns ns' (fullApp tm) w return $ PClause fc wname lhs ws rhs wheres- mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs)+ mkAux pn wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval pn' withs) = do i <- getIState let tm = addImplPat i tm_in logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " ++ showTmImpls toplhs)- withs' <- mapM (mkAuxC wname toplhs ns ns') withs+ withs' <- mapM (mkAuxC pn wname toplhs ns ns') withs case matchClause i toplhs tm of Left (a,b) -> trace ("matchClause: " ++ show a ++ " =/= " ++ show b) (ifail $ show fc ++ "with clause does not match top level") Right mvars ->- do lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w- return $ PWith fc wname lhs ws wval withs'- mkAux wname toplhs ns ns' c+ do lhs <- updateLHS n pn wname mvars ns ns' (fullApp tm) w+ return $ PWith fc wname lhs ws wval pn' withs'+ mkAux pn wname toplhs ns ns' c = ifail $ show fc ++ ":badly formed with clause" addArg (PApp fc f args) w = PApp fc f (args ++ [pexp w]) addArg (PRef fc f) w = PApp fc (PRef fc f) [pexp w] - updateLHS n wname mvars ns_in ns_in' (PApp fc (PRef fc' n') args) w+ updateLHS n pn wname mvars ns_in ns_in' (PApp fc (PRef fc' n') args) w = let ns = map (keepMvar (map fst mvars) fc') ns_in ns' = map (keepMvar (map fst mvars) fc') ns_in' in return $ substMatches mvars $ PApp fc (PRef fc' wname)- (map pexp ns ++ pexp w : (map pexp ns'))- updateLHS n wname mvars ns_in ns_in' tm w- = updateLHS n wname mvars ns_in ns_in' (PApp fc tm []) w+ (map pexp ns ++ pexp w : (map pexp ns') ++ + case pn of+ Nothing -> []+ Just pnm -> [pexp (PRef fc pnm)])+ updateLHS n pn wname mvars ns_in ns_in' tm w+ = updateLHS n pn wname mvars ns_in ns_in' (PApp fc tm []) w keepMvar mvs fc v | v `elem` mvs = PRef fc v | otherwise = Placeholder
src/Idris/Elab/Data.hs view
@@ -215,6 +215,7 @@ Idris (Name, Type) elabCon info syn tn codata expkind (doc, argDocs, n, 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) ctxt <- getContext let cty' = normalise ctxt [] cty@@ -223,7 +224,7 @@ -- Check that the constructor type is, in fact, a part of the family being defined tyIs n cty' - logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t+ logLvl 5 $ show fc ++ ":Constructor " ++ show n ++ " elaborated : " ++ show t logLvl 5 $ "Inaccessible args: " ++ show inacc logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty' @@ -316,11 +317,13 @@ eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs) let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses elimLog $ "-- case function definition: " ++ (show . showDeclImp verbosePPOption) eliminatorDef- State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorTyDecl) (\err -> return ())+ State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorTyDecl)+ (ierror . Elaborating "type declaration of " elimDeclName) -- Do not elaborate clauses if there aren't any case eliminatorClauses of [] -> State.lift $ solveDeferred elimDeclName -- Remove meta-variable for type- _ -> State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorDef) (\err -> return ())+ _ -> State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorDef)+ (ierror . Elaborating "clauses of " elimDeclName) where elimLog :: String -> EliminatorState () elimLog s = State.lift (logLvl 2 s)
src/Idris/Elab/Instance.hs view
@@ -51,6 +51,8 @@ import Util.Pretty(pretty, text) elabInstance :: ElabInfo -> SyntaxInfo ->+ Docstring (Either Err PTerm) ->+ [(Name, Docstring (Either Err PTerm))] -> ElabWhat -> -- phase FC -> [(Name, PTerm)] -> -- constraints Name -> -- the class@@ -58,7 +60,7 @@ PTerm -> -- full instance type Maybe Name -> -- explicit name [PDecl] -> Idris ()-elabInstance info syn what fc cs n ps t expn ds = do+elabInstance info syn doc argDocs what fc cs n ps t expn ds = do i <- getIState (n, ci) <- case lookupCtxtName n (idris_classes i) of [c] -> return c@@ -69,11 +71,11 @@ 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 emptyDocstring [] fc [] iname t+ nty <- elabType' True info syn doc argDocs fc [] iname t -- if the instance type matches any of the instances we have already, -- and it's not a named instance, then it's overlapping, so report an error case expn of- Nothing -> do mapM_ (maybe (return ()) overlapping . findOverlapping i (delab i nty))+ 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@@ -86,6 +88,7 @@ -- where block wparams <- mapM (\p -> case p of PApp _ _ args -> getWParams (map getTm args)+ a@(PRef fc f) -> getWParams [a] _ -> return []) ps let pnames = map pname (concat (nub wparams)) let superclassInstances = map (substInstance ips pnames) (class_default_superclasses ci)@@ -101,8 +104,11 @@ op, coninsert cs t', t')) (class_methods ci) logLvl 3 (show (mtys, ips))- let ds' = insertDefaults i iname (class_defaults ci) ns ds- iLOG ("Defaults inserted: " ++ show ds' ++ "\n" ++ show ci)+ logLvl 5 ("Before defaults: " ++ show ds ++ "\n" ++ show (map fst (class_methods ci)))+ let ds_defs = insertDefaults i iname (class_defaults ci) ns ds+ logLvl 3 ("After defaults: " ++ show ds_defs ++ "\n")+ let ds' = reorderDefs (map fst (class_methods ci)) $ ds_defs+ iLOG ("Reordered: " ++ show ds' ++ "\n") mapM_ (warnMissing ds' ns iname) (map fst (class_methods ci)) mapM_ (checkInClass (map fst (class_methods ci))) (concatMap defined ds') let wbTys = map mkTyDecl mtys@@ -133,6 +139,8 @@ [PClause fc iname lhs [] rhs wb]] iLOG (show idecls) 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) where@@ -147,10 +155,10 @@ Just m -> sNS (SN (sInstanceN n' (map show ps'))) m Just nm -> nm - substInstance ips pnames (PInstance syn _ cs n ps t expn ds)- = PInstance syn fc cs n (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds+ 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 - isOverlapping i (PInstance syn _ _ n ps t expn _)+ isOverlapping i (PInstance doc argDocs syn _ _ n 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@@ -165,33 +173,45 @@ = do ty' <- addUsingConstraints syn fc t -- TODO think: something more in info? ty' <- implicit info syn iname ty'- let ty = addImpl i ty'+ let ty = addImpl [] i ty' ctxt <- getContext- ((tyT, _, _), _) <-- tclift $ elaborate ctxt iname (TType (UVal 0)) initEState- (errAt "type of " iname (erun fc (build i info ERHS [] iname ty)))+ (ElabResult tyT _ _ ctxt' newDecls, _) <-+ tclift $ elaborate ctxt iname (TType (UVal 0)) initEState+ (errAt "type of " iname (erun fc (build i info ERHS [] iname ty)))+ setContext ctxt'+ processTacticDecls newDecls ctxt <- getContext- (cty, _) <- recheckC fc [] tyT+ (cty, _) <- recheckC fc id [] tyT let nty = normalise ctxt [] cty- return $ any (isJust . findOverlapping i (delab i nty)) (class_instances ci)+ return $ any (isJust . findOverlapping i (class_determiners ci) (delab i nty)) (class_instances ci) - findOverlapping i t n+ findOverlapping i dets t n | take 2 (show n) == "@@" = Nothing | otherwise = case lookupTy n (tt_ctxt i) of [t'] -> let tret = getRetType t tret' = getRetType (delab i t') in- case matchClause i tret' tret of- Right ms -> Just tret'- Left _ -> case matchClause i tret tret' of- Right ms -> Just tret'- Left _ -> Nothing+ case matchArgs i dets tret' tret of+ Right _ -> Just tret'+ Left _ -> case matchArgs i dets tret tret' of+ Right _ -> Just tret'+ Left _ -> Nothing _ -> Nothing overlapping t' = tclift $ tfail (At fc (Msg $ "Overlapping instance: " ++ show t' ++ " already defined")) getRetType (PPi _ _ _ sc) = getRetType sc getRetType t = t + matchArgs i dets x y =+ let x' = keepDets dets x+ y' = keepDets dets y in+ matchClause i x' y'++ keepDets dets (PApp fc f args)+ = PApp fc f $ let a' = zip [0..] args in+ map snd (filter (\(i, _) -> i `elem` dets) a')+ keepDets dets t = t+ mkMethApp (n, _, _, ty) = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty)) lamBind i (PPi (Constraint _ _) _ _ sc) sc'@@ -223,7 +243,9 @@ 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 t+ mkTyDecl (n, op, t, _) + = PTy emptyDocstring [] syn fc op n + (mkUniqueNames [] t) conbind :: [(Name, PTerm)] -> PTerm -> PTerm conbind ((c,ty) : ns) x = PPi constraint c ty (conbind ns x)@@ -233,6 +255,22 @@ coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc) coninsert cs sc = conbind cs sc + -- Reorder declarations to be in the same order as defined in the+ -- class declaration (important so that we insert default definitions+ -- in the right place, and so that dependencies between methods are+ -- respected)+ reorderDefs :: [Name] -> [PDecl] -> [PDecl]+ reorderDefs ns [] = []+ reorderDefs [] ds = ds+ reorderDefs (n : ns) ds = case pick n [] ds of + Just (def, ds') -> def : reorderDefs ns ds'+ Nothing -> reorderDefs ns ds++ pick n acc [] = Nothing + pick n acc (def@(PClauses _ _ cn cs) : ds)+ | nsroot n == nsroot cn = Just (def, acc ++ ds)+ pick n acc (d : ds) = pick n (acc ++ [d]) ds+ insertDefaults :: IState -> Name -> [(Name, (Name, PDecl))] -> [T.Text] -> [PDecl] -> [PDecl]@@ -262,3 +300,28 @@ clauseFor m iname ns (PClauses _ _ m' _) = decorate ns iname m == decorate ns iname m' clauseFor m iname ns _ = False++checkInjectiveArgs :: FC -> Name -> [Int] -> Maybe Type -> Idris ()+checkInjectiveArgs fc n ds Nothing = return ()+checkInjectiveArgs fc n ds (Just ty)+ = do ist <- getIState+ let (_, args) = unApply (instantiateRetTy ty)+ ci 0 ist args+ where+ ci i ist (a : as) | i `elem` ds + = if isInj ist a then ci (i + 1) ist as+ else tclift $ tfail (At fc (InvalidTCArg n a))+ ci i ist (a : as) = ci (i + 1) ist as+ ci i ist [] = return ()++ 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 (V _) = True+ isInj i (Bind n b sc) = isInj i sc+ isInj _ _ = True++ instantiateRetTy (Bind n (Pi _ _ _) sc)+ = substV (P Bound n Erased) (instantiateRetTy sc)+ instantiateRetTy t = t+
src/Idris/Elab/Provider.hs view
@@ -52,8 +52,8 @@ import Util.Pretty(pretty, text) -- | Elaborate a type provider-elabProvider :: ElabInfo -> SyntaxInfo -> FC -> ProvideWhat -> Name -> Idris ()-elabProvider info syn fc what n+elabProvider :: Docstring (Either Err PTerm) -> ElabInfo -> SyntaxInfo -> FC -> ProvideWhat -> Name -> Idris ()+elabProvider doc info syn fc what n = do i <- getIState -- Ensure that the experimental extension is enabled unless (TypeProviders `elem` idris_language_extensions i) $@@ -74,9 +74,9 @@ (e, et) <- case what of ProvTerm _ tm -> elabVal info ERHS tm ProvPostulate tm -> elabVal info ERHS tm- unless (isProviderOf (normalise ctxt [] ty') et) $- ifail $ "Expected provider type IO (Provider (" ++- show ty' ++ "))" ++ ", got " ++ show et ++ " instead."+ unless (isProviderOf ctxt ty' et) $+ ifail $ "Expected provider type " ++ show (providerOf ty') +++ ", got " ++ show et ++ " instead." -- Execute the type provider and normalise the result -- use 'run__provider' to convert to a primitive IO action@@ -93,12 +93,12 @@ Provide tm | ProvTerm ty _ <- what -> do -- Finally add a top-level definition of the provided term- elabType info syn emptyDocstring [] fc [] n ty+ elabType info syn doc [] fc [] n 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 -> do -- Add the postulate- elabPostulate info syn (fmap (const (Left $ Msg "")) . parseDocstring $ T.pack "Provided postulate") fc [] n (delab i tm)+ elabPostulate info syn doc fc [] n (delab i tm) logLvl 3 $ "Elaborated provided postulate " ++ show n | otherwise -> ierror . Msg $ "Attempted to provide a postulate where a term was expected."@@ -107,11 +107,16 @@ isTType (TType _) = True isTType _ = False - isProviderOf :: TT Name -> TT Name -> Bool- isProviderOf tp prov- | (P _ (UN io) _, [prov']) <- unApply prov- , (P _ (NS (UN prov) [provs]) _, [tp']) <- unApply prov'- , tp == tp', io == txt "IO"- , prov == txt "Provider" && provs == txt "Providers" = True- isProviderOf _ _ = False+ -- Note: IO (Providers.Provider ty) is used instead of IO'+ -- (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)+ ty + isProviderOf :: Context -> TT Name -> TT Name -> Bool+ isProviderOf ctxt tp prov =+ case converts ctxt [] (providerOf tp) prov of+ OK _ -> True+ _ -> False
src/Idris/Elab/Transform.hs view
@@ -53,40 +53,46 @@ = do ctxt <- getContext i <- getIState let lhs = addImplPat i lhs_in- ((lhs', dlhs, []), _) <-+ (ElabResult lhs' dlhs [] ctxt' newDecls, _) <- tclift $ elaborate ctxt (sMN 0 "transLHS") infP initEState (erun fc (buildTC i info ELHS [] (sUN "transform") (infTerm lhs)))+ setContext ctxt'+ processTacticDecls newDecls let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs' let newargs = pvars i lhs_tm - (clhs_tm_in, clhs_ty) <- recheckC fc [] lhs_tm+ (clhs_tm_in, clhs_ty) <- recheckC fc id [] lhs_tm let clhs_tm = renamepats pnames clhs_tm_in logLvl 3 ("Transform LHS " ++ show clhs_tm) let rhs = addImplBound i (map fst newargs) rhs_in- ((rhs', defer), _) <-+ ((rhs', defer, ctxt', newDecls), _) <- tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty initEState (do pbinds i lhs_tm setNextName- erun fc (build i info ERHS [] (sUN "transform") rhs)+ (ElabResult _ _ _ ctxt' newDecls) <- erun fc (build i info ERHS [] (sUN "transform") rhs) erun fc $ psolve lhs_tm tt <- get_term- return (runState (collectDeferred Nothing tt) []))- (crhs_tm_in, crhs_ty) <- recheckC fc [] rhs'+ let (rhs', defer) = runState (collectDeferred Nothing tt) []+ return (rhs', defer, ctxt', newDecls))+ setContext ctxt'+ processTacticDecls newDecls++ (crhs_tm_in, crhs_ty) <- recheckC fc id [] rhs' let crhs_tm = renamepats pnames crhs_tm_in logLvl 3 ("Transform RHS " ++ show crhs_tm) -- Types must always convert case converts ctxt [] clhs_ty crhs_ty of OK _ -> return ()- Error e -> ierror (At fc (CantUnify False clhs_tm crhs_tm e [] 0))+ Error e -> ierror (At fc (CantUnify False (clhs_tm, Nothing) (crhs_tm, Nothing) e [] 0)) -- In safe mode, values must convert (Thinks: This is probably not -- useful as is, perhaps it should require a proof of equality instead) when safe $ case converts ctxt [] clhs_tm crhs_tm of OK _ -> return ()- Error e -> ierror (At fc (CantUnify False clhs_tm crhs_tm e [] 0))+ Error e -> ierror (At fc (CantUnify False (clhs_tm, Nothing) (crhs_tm, Nothing) e [] 0)) case unApply (depat clhs_tm) of (P _ tfname _, _) -> do addTrans tfname (clhs_tm, crhs_tm)
src/Idris/Elab/Type.hs view
@@ -57,23 +57,25 @@ ctxt <- getContext i <- getIState - logLvl 3 $ show n ++ " pre-type " ++ showTmImpls ty'+ logLvl 2 $ show n ++ " pre-type " ++ showTmImpls ty' ++ show (no_imp syn) ty' <- addUsingConstraints syn fc ty' ty' <- addUsingImpls syn n fc ty'- let ty = addImpl i ty'+ let ty = addImpl (imp_methods syn) i ty' - logLvl 3 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'- logLvl 3 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty+ logLvl 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'+ logLvl 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty - ((tyT', defer, is), log) <-- tclift $ elaborate ctxt n (TType (UVal 0)) initEState- (errAt "type of " n (erun fc (build i info ETyDecl [] n ty)))+ (ElabResult tyT' defer is ctxt' newDecls, log) <-+ tclift $ elaborate ctxt n (TType (UVal 0)) initEState+ (errAt "type of " n (erun fc (build i info ETyDecl [] n ty)))+ setContext ctxt'+ processTacticDecls newDecls let tyT = patToImp tyT' logLvl 3 $ show ty ++ "\nElaborated: " ++ show tyT' - ds <- checkAddDef True False fc defer+ 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@@ -83,14 +85,14 @@ logLvl 5 $ "Rechecking" logLvl 6 $ show tyT logLvl 10 $ "Elaborated to " ++ showEnvDbg [] tyT- (cty, ckind) <- recheckC fc [] tyT+ (cty, ckind) <- recheckC fc id [] tyT -- record the implicit and inaccessible arguments i <- getIState let (inaccData, impls) = unzip $ getUnboundImplicits i cty ty let inacc = inaccessibleImps 0 cty inaccData logLvl 3 $ show n ++ ": inaccessible arguments: " ++ show inacc ++- " from " ++ show (cty, ty)+ " from " ++ show cty ++ "\n" ++ showTmImpls ty putIState $ i { idris_implicits = addDef n impls (idris_implicits i) } logLvl 3 ("Implicit " ++ show n ++ " " ++ show impls)@@ -114,12 +116,14 @@ param_pos i ns t = [] -- | 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+elabType :: ElabInfo -> SyntaxInfo+ -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))]+ -> FC -> FnOpts -> Name -> PTerm -> Idris Type elabType = elabType' False elabType' :: Bool -> -- normalise it- ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] ->+ ElabInfo -> SyntaxInfo ->+ Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] -> FC -> FnOpts -> Name -> PTerm -> Idris Type elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in n = liftname info n_in in -}@@ -150,7 +154,7 @@ -- Productivity checking now via checking for guarded 'Delay' let opts' = opts -- if corec then (Coinductive : opts) else opts let usety = if norm then nty' else nty- ds <- checkDef fc [(n, (-1, Nothing, usety))]+ ds <- checkDef fc iderr [(n, (-1, Nothing, usety))] addIBC (IBCDef n) let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds addDeferred ds'@@ -181,6 +185,12 @@ 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."+ -- if it's an export list type, make a note of it+ case (unApply usety) of+ (P _ ut _, _) + | ut == ffiexport -> do addIBC (IBCExport n)+ addExport n+ _ -> return () return usety where -- for making an internalapp, we only want the explicit ones, and don't@@ -190,6 +200,8 @@ | e == e' = PPi e n ty (mergeTy sc sc') | otherwise = mergeTy sc sc' mergeTy _ sc = sc++ ffiexport = sNS (sUN "FFI_Export") ["FFI_Export"] err = txt "Err" maybe = txt "Maybe"
src/Idris/Elab/Utils.hs view
@@ -22,31 +22,41 @@ import qualified Data.Map as Map -recheckC = recheckC_borrowing False [] +recheckC = recheckC_borrowing False [] -recheckC_borrowing uniq_check bs fc env t+recheckC_borrowing uniq_check bs fc mkerr env t = do -- t' <- applyOpts (forget t) (doesn't work, or speed things up...) ctxt <- getContext- (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs ctxt env (forget t) t of- Error e -> tfail (At fc e)+ t' <- case safeForget t of+ Just ft -> return ft+ Nothing -> tclift $ tfail $ mkerr (At fc (IncompleteTerm t))+ (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs ctxt env t' t of+ Error e -> tfail (At fc (mkerr e)) OK x -> return x logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs addConstraints fc cs return (tm, ty) +iderr :: Name -> Err -> Err+iderr _ e = e -checkDef fc ns = checkAddDef False True fc ns+checkDef :: FC -> (Name -> Err -> Err) -> [(Name, (Int, Maybe Name, Type))]+ -> Idris [(Name, (Int, Maybe Name, Type))]+checkDef fc mkerr ns = checkAddDef False True fc mkerr ns -checkAddDef add toplvl fc [] = return []-checkAddDef add toplvl fc ((n, (i, top, t)) : ns) +checkAddDef :: Bool -> Bool -> FC -> (Name -> Err -> Err)+ -> [(Name, (Int, Maybe Name, Type))]+ -> Idris [(Name, (Int, Maybe Name, Type))]+checkAddDef add toplvl fc mkerr [] = return []+checkAddDef add toplvl fc mkerr ((n, (i, top, t)) : ns) = do ctxt <- getContext- (t', _) <- recheckC fc [] t+ (t', _) <- recheckC fc (mkerr n) [] t when add $ do addDeferred [(n, (i, top, t, toplvl))] addIBC (IBCDef n)- ns' <- checkAddDef add toplvl fc ns+ ns' <- checkAddDef add toplvl fc mkerr ns return ((n, (i, top, t')) : ns') --- Get the list of (index, name) of inaccessible arguments from an elaborated+-- | Get the list of (index, name) of inaccessible arguments from an elaborated -- type inaccessibleImps :: Int -> Type -> [Bool] -> [(Int, Name)] inaccessibleImps i (Bind n (Pi _ t _) sc) (inacc : ins)@@ -54,7 +64,7 @@ | otherwise = inaccessibleImps (i + 1) sc ins inaccessibleImps _ _ _ = [] --- Get the list of (index, name) of inaccessible arguments from the type.+-- | Get the list of (index, name) of inaccessible arguments from the type. inaccessibleArgs :: Int -> PTerm -> [(Int, Name)] inaccessibleArgs i (PPi (Imp _ _ _ _) n Placeholder t) = (i,n) : inaccessibleArgs (i+1) t -- unbound implicit@@ -74,10 +84,9 @@ when (AssertTotal `elem` opts) $ setFlags n [AssertTotal] rec_elabDecl info EAll info (PClauses f opts' n ps ) --- Check that the result of type checking matches what the programmer wrote+-- | Check that the result of type checking matches what the programmer wrote -- (i.e. - if we inferred any arguments that the user provided, make sure -- they are the same!)- checkInferred :: FC -> PTerm -> PTerm -> Idris () checkInferred fc inf user = do logLvl 6 $ "Checked to\n" ++ showTmImpls inf ++ "\n\nFROM\n\n" ++@@ -92,9 +101,8 @@ logLvl 10 $ "Checked match" -- ++ "\n" ++ showImp True inf ++ "\n" ++ showImp True user) --- Return whether inferred term is different from given term+-- | Return whether inferred term is different from given term -- (as above, but return a Bool)- inferredDiff :: FC -> PTerm -> PTerm -> Idris Bool inferredDiff fc inf user = do i <- getIState@@ -120,8 +128,8 @@ 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- dc (PWith fc n t as w ds)- = PWith fc (decorate n) (dappname t) as w+ dc (PWith fc n t as w pn ds)+ = PWith fc (decorate n) (dappname t) as w pn (map (decorateid decorate) ds) dappname (PApp fc (PRef fc' n) as) = PApp fc (PRef fc' (decorate n)) as dappname t = t
src/Idris/Elab/Value.hs view
@@ -56,25 +56,30 @@ elabValBind info aspat norm tm_in = do ctxt <- getContext i <- getIState- let tm = addImpl i tm_in+ let tm = addImpl [] i tm_in logLvl 10 (showTmImpls tm) -- try: -- * ordinary elaboration -- * elaboration as a Type -- * elaboration as a function a -> b - ((tm', defer, is), _) <-- tclift (elaborate ctxt (sMN 0 "val") infP initEState- (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))+ (ElabResult tm' defer is ctxt' newDecls, _) <-+ tclift (elaborate ctxt (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+ let vtm = orderPats (getInferTerm tm') - def' <- checkDef (fileFC "(input)") defer+ def' <- checkDef (fileFC "(input)") iderr defer let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def' addDeferred def'' mapM_ (elabCaseBlock info []) is logLvl 3 ("Value: " ++ show vtm)- (vtm_in, vty) <- recheckC (fileFC "(input)") [] vtm+ (vtm_in, vty) <- recheckC (fileFC "(input)") id [] vtm let vtm = if norm then normalise (tt_ctxt i) [] vtm_in else vtm_in
src/Idris/ElabDecls.hs view
@@ -200,11 +200,11 @@ where isDataDecl (PData _ _ _ _ _ _) = True isDataDecl _ = False - setMutData ns n + setMutData ns n = do i <- getIState case lookupCtxt n (idris_datatypes i) of [x] -> do let x' = x { mutual_types = ns }- putIState $ i { idris_datatypes + putIState $ i { idris_datatypes = addDef n x' (idris_datatypes i) } _ -> return () @@ -229,13 +229,13 @@ 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 ds)+elabDecl' what info (PClass doc s f cs n ps pdocs fds ds) | what /= EDefns = do iLOG $ "Elaborating class " ++ show n- elabClass info (s { syn_params = [] }) doc f cs n ps pdocs ds-elabDecl' what info (PInstance s f cs n ps t expn ds)+ 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) = do iLOG $ "Elaborating instance " ++ show n- elabInstance info s what f cs n ps t expn ds+ 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) | what /= ETypes = do iLOG $ "Elaborating record " ++ show tyn@@ -249,12 +249,11 @@ addIBC (IBCDSL n) elabDecl' what info (PDirective i) | what /= EDefns = i-elabDecl' what info (PProvider syn fc provWhat n)+elabDecl' what info (PProvider doc syn fc provWhat n) | what /= EDefns = do iLOG $ "Elaborating type provider " ++ show n- elabProvider info syn fc provWhat n+ elabProvider doc info syn fc provWhat n elabDecl' what info (PTransform fc safety old new) = do elabTransform info fc safety old new return () elabDecl' _ _ _ = return () -- skipped this time-
src/Idris/ElabQuasiquote.hs view
@@ -36,6 +36,7 @@ return (GoalType s tac', ex) 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 extractPArgUnquotes :: Int -> PArg -> Elab' aux (PArg, [(Name, PTerm)])@@ -169,6 +170,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 x = return (x, []) -- no subterms!
src/Idris/ElabTerm.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE PatternGuards #-}-+{-# LANGUAGE PatternGuards, ViewPatterns #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.ElabTerm where import Idris.AbsSyntax@@ -18,6 +18,7 @@ import Idris.ErrReverse (errReverse) import Idris.ElabQuasiquote (extractUnquotes) import Idris.Elab.Utils+import Idris.Reflection import qualified Util.Pretty as U import Control.Applicative ((<$>))@@ -36,6 +37,32 @@ 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. --@@ -45,7 +72,7 @@ -- Also find deferred names in the term and their types build :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->- ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])+ ElabD ElabResult build ist info emode opts fn tm = do elab ist info emode opts fn tm let tmIn = tm@@ -64,7 +91,7 @@ mapM_ (\n -> when (n `elem` hs) $ do focus n g <- goal- try (resolveTC True 7 g fn ist)+ try (resolveTC True False 7 g fn ist) (movelast n)) ivs ivs <- get_instances hs <- get_holes@@ -72,7 +99,8 @@ mapM_ (\n -> when (n `elem` hs) $ do focus n g <- goal- resolveTC True 7 g fn ist) ivs+ ptm <- get_term+ resolveTC True True 7 g fn ist) ivs tm <- get_term ctxt <- get_context probs <- get_probs@@ -94,12 +122,13 @@ when tydecl (do update_term orderPats mkPat) -- update_term liftPats)- EState is _ <- getAux+ EState is _ impls <- getAux tt <- get_term let (tm, ds) = runState (collectDeferred (Just fn) tt) [] log <- getLog- if (log /= "") then trace log $ return (tm, ds, is)- else return (tm, ds, is)+ 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 @@ -114,7 +143,7 @@ -- know about yet on the LHS of a pattern def) buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->- ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])+ ElabD ElabResult buildTC ist info emode opts fn tm = do -- set name supply to begin after highest index in tm let ns = allNamesIn tm@@ -135,12 +164,13 @@ -- unification when (not (null dots)) $ lift (Error (CantMatch (getInferTerm tm)))- EState is _ <- getAux+ EState is _ impls <- getAux tt <- get_term let (tm, ds) = runState (collectDeferred (Just fn) tt) [] log <- getLog- if (log /= "") then trace log $ return (tm, ds, is)- else return (tm, ds, is)+ 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 @@ -164,13 +194,14 @@ 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+initElabCtxt = ElabCtxt False False False False False False goal_polymorphic :: ElabD Bool goal_polymorphic =@@ -182,9 +213,9 @@ _ -> return True _ -> return False --- Returns the set of declarations we need to add to complete the definition--- (most likely case blocks to elaborate)-+-- | 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@@ -244,7 +275,7 @@ then solveAuto ist fn False a else return ()) as - itm <- if not pattern then insertImpLam t else return t+ itm <- if not pattern then insertImpLam ina t else return t ct <- insertCoerce ina itm t' <- insertLazy ct g <- goal@@ -267,10 +298,10 @@ pimp (sUN "a") Placeholder True, pexp ct])) True - forceErr env (CantUnify _ t t' _ _ _)+ forceErr env (CantUnify _ (t,_) (t',_) _ _ _) | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t), ht == txt "Lazy'" = True- forceErr env (CantUnify _ t t' _ _ _)+ forceErr env (CantUnify _ (t,_) (t',_) _ _ _) | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t'), ht == txt "Lazy'" = True forceErr env (InfiniteUnify _ t _)@@ -308,7 +339,7 @@ | 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 && e_nomatching ina+ | 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@@ -317,9 +348,10 @@ 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 5 g fn ist+ = do g <- goal; resolveTC False False 5 g fn ist elab' ina fc (PResolveTC fc') = do c <- getNameFrom (sMN 0 "class") instanceArg c@@ -352,13 +384,32 @@ 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])- _ -> elab' ina (Just fc) (PApp fc (PRef fc pairCon)+ 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 ->@@ -399,6 +450,7 @@ 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@@ -411,7 +463,7 @@ | 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 && e_nomatching ec+ | 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@@ -439,7 +491,7 @@ | 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 && e_nomatching ina+ | 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@@ -518,14 +570,15 @@ g <- goal hs <- get_holes if all (\n -> n == tyn || not (n `elem` hs)) (freeNames g)- then try (resolveTC True 7 g fn ist)+ 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)+ 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@@ -596,17 +649,13 @@ _ -> lift $ tfail (NoSuchVariable fn) ns <- match_apply (Var fn') (map (\x -> (x,0)) imps) solve- -- This isn't a sound way of checking for Typecase - we need a - -- better way!--- elab' (_, _, inty, qq) (PApp fc (PRef _ f) args')--- | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty && not qq--- = lift $ tfail (Msg "Typecase is not allowed") -- if f is local, just do a simple_app- elab' ina _ tm@(PApp fc (PRef _ f) args_in)- | pattern && not reflection && e_nomatching ina+ -- 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- = do env <- get_env+ | otherwise = implicitApp $+ do env <- get_env ty <- goal fty <- get_type (Var f) ctxt <- get_context@@ -614,18 +663,18 @@ let unmatchableArgs = if pattern then getUnmatchable (tt_ctxt ist) f else []- -- Dot it if we're in a pattern and it isn't a constructor--- when (pattern && not (isDConName f ctxt) && f /= fn) $ dotterm-+-- 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 (elabE ina (Just fc) (PRef fc f))+ 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@@ -656,22 +705,58 @@ (zip ns' (unmatchableArgs ++ repeat False)) (f == sUN "Force") (map (\x -> getTm x) eargs) -- TODO: remove this False arg- solve- 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 7 g fn ist)- (movelast n)- else movelast n)- (ivs' \\ ivs)- where -- normal < alternatives < lambdas < rewrites < tactic < default tactic+ 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@@ -720,10 +805,10 @@ Just b -> case unApply (binderTy b) of (P _ c _, args) ->- case lookupCtxt c (idris_classes ist) of- [] -> return ()- _ -> -- type class, set as injective- do mapM_ setinjArg 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@@ -736,6 +821,10 @@ 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@@ -744,11 +833,24 @@ setInjective (PApp _ (PRef _ n) _) = setinj n setInjective _ = return () - elab' ina _ tm@(PApp fc f [arg])- = erun fc $- do simple_app (elabE ina (Just fc) f) (elabE (ina { e_inarg = True }) (Just fc) (getTm arg))- (show tm)+ 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@@ -822,9 +924,21 @@ envU <- mapM (getKind args) args let namesUsedInRHS = nub $ scvn : concatMap (\(_,rhs) -> allNamesIn rhs) opts - -- Drop the unique arguments used in the scrutinee (since it's- -- not valid to use them again anyway)- let argsDropped = filter (isUnique envU) (nub $ allNamesIn scr)+ -- 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)@@ -851,6 +965,13 @@ 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@@ -878,14 +999,14 @@ elab' ina fc (PUnifyLog t) = do unifyLog True elab' ina fc t unifyLog False- elab' ina fc (PQuasiquote t goal) -- TODO: goal type+ 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- -- of type TT.+ -- an inferred type (to support polytypic quasiquotes).+ finalTy <- goal (t, unq) <- extractUnquotes 0 t let unquoteNames = map fst unq- mapM_ (flip claim (Var tt)) unquoteNames-+ 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.@@ -893,7 +1014,7 @@ saveState updatePS (const . newProof (sMN 0 "q") ctxt $- P Ref tt Erased)+ 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@@ -920,7 +1041,7 @@ letbind nTm (Var qTy) (Var qTm) -- Fill out the goal type, if relevant- case goal of+ case goalt of Nothing -> return () Just gTy -> do focus qTy elabE (ina { e_qq = True }) fc gTy@@ -935,23 +1056,29 @@ 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 reflectQuotePattern unquoteNames q'- else do fill $ reflectQuote unquoteNames q'+ 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 tt = sNS (sUN "TT") ["Reflection", "Language"]-- elabUnquote (n, tm)+ where elabUnquote (n, tm) = do focus n elabE (ina { e_qq = False }) fc tm @@ -972,6 +1099,20 @@ 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] }) @@ -995,6 +1136,7 @@ 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@@ -1068,16 +1210,20 @@ = x : insertScopedImps fc sc xs insertScopedImps _ _ xs = xs - insertImpLam t =+ 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")- return (PLam emptyFC impn Placeholder t)+ 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@@ -1096,7 +1242,7 @@ PAlternative True (map (mkCoerce env t) cs)] return t' where- mkCoerce env t n = let fc = fileFC "Coercion" in -- line never appears!+ 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)]) @@ -1152,7 +1298,8 @@ 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@@ -1232,9 +1379,12 @@ findInstances ist t | (P _ n _, _) <- unApply t = case lookupCtxt n (idris_classes ist) of- [CI _ _ _ _ _ ins] -> ins+ [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 ()@@ -1262,14 +1412,26 @@ -- 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 -> Int -> Term -> Name -> IState -> ElabD ()-resolveTC = resTC' []+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 0 topg fn ist = fail $ "Can't resolve type class"-resTC' tcs def 1 topg fn ist = try' (trivial' ist) (resolveTC def 0 topg fn ist) True-resTC' tcs defaultOn depth topg fn ist- = do compute- g <- goal+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@@ -1286,6 +1448,31 @@ 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) @@ -1313,10 +1500,13 @@ blunderbuss t d stk [] = do -- c <- get_env -- ps <- get_probs- lift $ tfail $ CantResolve topg+ lift $ tfail $ CantResolve False topg blunderbuss t d stk (n:ns) | n /= fn && (n `elem` stk || tcname n) - = try' (resolve n d) (blunderbuss t d stk ns) True+ = 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@@ -1330,6 +1520,7 @@ 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)@@ -1344,7 +1535,7 @@ let got = fst (unApply t) let depth' = if tc' `elem` tcs then depth - 1 else depth- resTC' (got : tcs) defaultOn depth' topg fn ist)+ 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@@ -1390,6 +1581,139 @@ 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 @@ -1456,6 +1780,12 @@ 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")@@ -1516,6 +1846,10 @@ = 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@@ -1624,23 +1958,9 @@ case perhapsFC of Nothing -> lift . tfail $ Msg "There is no source location available." Just fc ->- do let intTy = RConstant (AType (ATInt ITNative))- fill $ 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)- ]- ]+ 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@@ -1660,6 +1980,7 @@ 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)@@ -1671,6 +1992,9 @@ 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)@@ -1701,16 +2025,20 @@ t'' <- reifyTT t' return $ LetTacTy n' (delab ist tt'') (delab ist t'') reifyApp ist t [errs]- | t == reflm "Fail" = 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 $ TFail 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 _ _)@@ -1753,7 +2081,7 @@ | (P _ f _, args) <- unApply t = reifyRawApp f args reifyRaw t@(P _ n _) | n == reflm "RType" = return $ RType-reifyRaw t = fail ("Unknown reflection raw term: " ++ show t)+reifyRaw t = fail ("Unknown reflection raw term in reifyRaw: " ++ show t) reifyRawApp :: Name -> [Term] -> ElabD Raw reifyRawApp t [n]@@ -1769,7 +2097,7 @@ | t == reflm "RForce" = liftM RForce (reifyRaw t') reifyRawApp t [c] | t == reflm "RConstant" = liftM RConstant (reifyTTConst c)-reifyRawApp t args = fail ("Unknown reflection raw term: " ++ show (t, args))+reifyRawApp t args = fail ("Unknown reflection raw term in reifyRawApp: " ++ show (t, args)) reifyTTName :: Term -> ElabD Name reifyTTName t@@ -1890,6 +2218,7 @@ 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 _ _)@@ -1906,8 +2235,12 @@ -- | Lift a term into its Language.Reflection.TT representation reflect :: Term -> Raw-reflect = reflectQuote []+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"]))@@ -1917,8 +2250,8 @@ -- 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.-reflectQuotePattern :: [Name] -> Term -> ElabD ()-reflectQuotePattern unq (P _ n _)+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 =@@ -1932,10 +2265,10 @@ fill $ reflCall "P" [Var nt, Var n', Var tyannot] solve focus n'; reflectNameQuotePattern n-reflectQuotePattern unq (V n)+reflectTTQuotePattern unq (V n) = do fill $ reflCall "V" [RConstant (I n)] solve-reflectQuotePattern unq (Bind n b x)+reflectTTQuotePattern unq (Bind n b x) = do x' <- claimTT (sMN 0 "sc") movelast x' b' <- getNameFrom (sMN 0 "binder")@@ -1955,112 +2288,216 @@ Var b', Var x'] solve- focus x'; reflectQuotePattern unq x- focus b'; reflectBinderQuotePattern unq b-- where- reflectBinderQuotePattern :: [Name] -> Binder Term -> ElabD ()- reflectBinderQuotePattern unq (Lam t)- = do t' <- claimTT (sMN 0 "ty"); movelast t'- fill $ reflCall "Lam" [Var (reflm "TT"), Var t']- solve- focus t'; reflectQuotePattern unq t- reflectBinderQuotePattern 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'; reflectQuotePattern unq t- reflectBinderQuotePattern 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'; reflectQuotePattern unq x- focus y'; reflectQuotePattern unq y- reflectBinderQuotePattern 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'; reflectQuotePattern unq x- focus y'; reflectQuotePattern unq y- reflectBinderQuotePattern unq (Hole t)- = do t' <- claimTT (sMN 0 "ty"); movelast t'- fill $ reflCall "Hole" [Var (reflm "TT"), Var t']- solve- focus t'; reflectQuotePattern unq t- reflectBinderQuotePattern unq (GHole _ t)- = do t' <- claimTT (sMN 0 "ty"); movelast t'- fill $ reflCall "GHole" [Var (reflm "TT"), Var t']- solve- focus t'; reflectQuotePattern unq t- reflectBinderQuotePattern 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'; reflectQuotePattern unq x- focus y'; reflectQuotePattern unq y- reflectBinderQuotePattern unq (PVar t)- = do t' <- claimTT (sMN 0 "ty"); movelast t'- fill $ reflCall "PVar" [Var (reflm "TT"), Var t']- solve- focus t'; reflectQuotePattern unq t- reflectBinderQuotePattern unq (PVTy t)- = do t' <- claimTT (sMN 0 "ty"); movelast t'- fill $ reflCall "PVTy" [Var (reflm "TT"), Var t']- solve- focus t'; reflectQuotePattern unq t-reflectQuotePattern unq (App f x)+ 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'; reflectQuotePattern unq f- focus x'; reflectQuotePattern unq x-reflectQuotePattern unq (Constant c)+ focus f'; reflectTTQuotePattern unq f+ focus x'; reflectTTQuotePattern unq x+reflectTTQuotePattern unq (Constant c) = do fill $ reflCall "TConst" [reflectConstant c] solve-reflectQuotePattern unq (Proj t i)+reflectTTQuotePattern unq (Proj t i) = do t' <- claimTT (sMN 0 "t"); movelast t' fill $ reflCall "Proj" [Var t', RConstant (I i)] solve- focus t'; reflectQuotePattern unq t-reflectQuotePattern unq (Erased)+ focus t'; reflectTTQuotePattern unq t+reflectTTQuotePattern unq (Erased) = do erased <- claimTT (sMN 0 "erased") movelast erased fill $ (Var erased) solve-reflectQuotePattern unq (Impossible)+reflectTTQuotePattern unq (Impossible) = do fill $ Var (reflm "Impossible") solve-reflectQuotePattern unq (TType exp)+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 --- | Create a reflected term, but leave refs to the provided name intact-reflectQuote :: [Name] -> Term -> Raw-reflectQuote unq (P nt n t)+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, reflectQuote unq t]-reflectQuote unq (V n)+ | otherwise = reflCall "P" [reflectNameType nt, reflectName n, reflectTTQuote unq t]+reflectTTQuote unq (V n) = reflCall "V" [RConstant (I n)]-reflectQuote unq (Bind n b x)- = reflCall "Bind" [reflectName n, reflectBinderQuote unq b, reflectQuote unq x]-reflectQuote unq (App f x)- = reflCall "App" [reflectQuote unq f, reflectQuote unq x]-reflectQuote unq (Constant c)+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]-reflectQuote unq (Proj t i)- = reflCall "Proj" [reflectQuote unq t, RConstant (I i)]-reflectQuote unq (Erased) = Var (reflm "Erased")-reflectQuote unq (Impossible) = Var (reflm "Impossible")-reflectQuote unq (TType exp) = reflCall "TType" [reflectUExp exp]+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")@@ -2110,27 +2547,27 @@ solve reflectBinder :: Binder Term -> Raw-reflectBinder = reflectBinderQuote []+reflectBinder = reflectBinderQuote reflectTTQuote (reflm "TT") [] -reflectBinderQuote :: [Name] -> Binder Term -> Raw-reflectBinderQuote unq (Lam t)- = reflCall "Lam" [Var (reflm "TT"), reflectQuote unq t]-reflectBinderQuote unq (Pi _ t k)- = reflCall "Pi" [Var (reflm "TT"), reflectQuote unq t, reflectQuote unq k]-reflectBinderQuote unq (Let x y)- = reflCall "Let" [Var (reflm "TT"), reflectQuote unq x, reflectQuote unq y]-reflectBinderQuote unq (NLet x y)- = reflCall "NLet" [Var (reflm "TT"), reflectQuote unq x, reflectQuote unq y]-reflectBinderQuote unq (Hole t)- = reflCall "Hole" [Var (reflm "TT"), reflectQuote unq t]-reflectBinderQuote unq (GHole _ t)- = reflCall "GHole" [Var (reflm "TT"), reflectQuote unq t]-reflectBinderQuote unq (Guess x y)- = reflCall "Guess" [Var (reflm "TT"), reflectQuote unq x, reflectQuote unq y]-reflectBinderQuote unq (PVar t)- = reflCall "PVar" [Var (reflm "TT"), reflectQuote unq t]-reflectBinderQuote unq (PVTy t)- = reflCall "PVTy" [Var (reflm "TT"), reflectQuote unq t]+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@@ -2170,7 +2607,8 @@ 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)]@@ -2226,7 +2664,7 @@ 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) =+reflectErr (CantUnify b (t1,_) (t2,_) e ctxt i) = raw_apply (Var $ reflErrName "CantUnify") [ rawBool b , reflect t1@@ -2276,11 +2714,15 @@ , reflect t2 , reflect t3 ]-reflectErr (CantResolve t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]+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 $ (sUN "String")) (map Var ss)]+ [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]@@ -2294,6 +2736,25 @@ 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)@@ -2401,6 +2862,28 @@ 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
src/Idris/Erasure.hs view
@@ -65,20 +65,21 @@ -- Perform usage analysis, write the relevant information in the internal -- structures, returning the list of reachable names.-performUsageAnalysis :: Idris [Name]-performUsageAnalysis = do+performUsageAnalysis :: [Name] -> Idris [Name]+performUsageAnalysis roots = do ctx <- tt_ctxt <$> getIState- mainName <- getMainName <$> getIState+ startNames <- getStartNames <$> getIState - case mainName of+ case startNames of Left reason -> return [] -- no main -> not compiling -> reachability irrelevant Right main -> do ci <- idris_classes <$> getIState cg <- idris_callgraph <$> getIState opt <- idris_optimisation <$> getIState+ used <- idris_erasureUsed <$> getIState -- Build the dependency graph.- let depMap = buildDepMap ci ctx main+ let depMap = buildDepMap ci used ctx main -- Search for reachable nodes in the graph. let (residDeps, (reachableNames, minUse)) = minimalUsage depMap@@ -105,11 +106,14 @@ return $ S.toList reachableNames where- getMainName :: IState -> Either Err Name- getMainName ist = case lookupCtxtName n (idris_implicits ist) of- [(n', _)] -> Right n'- [] -> Left (NoSuchVariable n)- more -> Left (CantResolveAlts (map fst more))+ 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"] @@ -170,12 +174,13 @@ -- Build the dependency graph, -- starting the depth-first search from a list of Names.-buildDepMap :: Ctxt ClassInfo -> Context -> Name -> Deps-buildDepMap ci ctx mainName = addPostulates $ dfs S.empty M.empty [mainName]+buildDepMap :: Ctxt ClassInfo -> [(Name, Int)] -> Context -> [Name] -> Deps+buildDepMap ci used ctx startNames = addPostulates used $ + dfs S.empty M.empty startNames where -- mark the result of Main.main as used with the empty assumption- addPostulates :: Deps -> Deps- addPostulates deps = foldr (\(ds, rs) -> M.insertWith (M.unionWith S.union) ds rs) deps postulates+ addPostulates :: [(Name, Int)] -> Deps -> Deps+ addPostulates used deps = foldr (\(ds, rs) -> M.insertWith (M.unionWith S.union) ds rs) deps (postulates used) where -- mini-DSL for postulates (==>) ds rs = (S.fromList ds, M.fromList [(r, S.empty) | r <- rs])@@ -187,18 +192,27 @@ usedNames = allNames deps S.\\ specialPrims usedPrims = [(p_name p, p_arity p) | p <- primitives, p_name p `S.member` usedNames] - postulates = + postulates used = [ [] ==> concat- -- These two, Main.main and run__IO, are always evaluated+ -- Main.main ( + export lists) and run__IO, are always evaluated -- but they elude analysis since they come from the seed term.- [ [(mainName, Result)] - , [(sUN "run__IO", Result), (sUN "run__IO", Arg 0)]+ [(map (\n -> (n, Result)) startNames)+ ,[(sUN "run__IO", Result), (sUN "run__IO", Arg 1)]+ ,[(sUN "call__IO", Result), (sUN "call__IO", Arg 2)] + -- Explicit usage declarations from a %used pragma+ , map (\(n, i) -> (n, Arg i)) used + -- MkIO is read by run__IO, -- but this cannot be observed in the source code of programs.- , it "MkIO" [1]+ , it "MkIO" [2] , it "prim__IO" [1] + -- Foreign calls are built with pairs, but mkForeign doesn't+ -- have an implementation so analysis won't see them+ , [(pairCon, Arg 2),+ (pairCon, Arg 3)] -- Used in foreign calls + -- these have been discovered as builtins but are not listed -- among Idris.Primitives.primitives --, mn "__MkPair" [2,3]@@ -380,8 +394,8 @@ -- which is the (Foreign a) spec that defines the type -- and is not needed at runtime. P _ (UN n) _- | n `elem` map T.pack ["mkForeign", "mkForeignPrim", "mkLazyForeignPrim"]- -> unconditionalDeps (drop 1 args)+ | n `elem` map T.pack ["mkForeignPrim"]+ -> unconditionalDeps args -- (drop 1 args) -- a bound variable might draw in additional dependencies, -- think: f x = x 0 <-- here, `x' _is_ used@@ -458,6 +472,7 @@ -- the easy cases getDepsTerm vs bs cd (Constant _) = M.empty getDepsTerm vs bs cd (TType _) = M.empty+ getDepsTerm vs bs cd (UType _) = M.empty getDepsTerm vs bs cd Erased = M.empty getDepsTerm vs bs cd Impossible = M.empty
src/Idris/Error.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Error where import Prelude hiding (catch) import Idris.AbsSyntax import Idris.Delaborate-import Idris.Output import Idris.Core.Evaluate (ctxtAlist) import Idris.Core.TT@@ -17,7 +17,6 @@ import System.Console.Haskeline.MonadException import Control.Monad (when) import Control.Monad.State.Strict-import Control.Monad.Except (throwError, catchError) import System.IO.Error(isUserError, ioeGetErrorString) import Data.Char import Data.List (intercalate, isPrefixOf)@@ -148,3 +147,5 @@ Foldable.mapM_ (warnDisamb ist) goal warnDisamb ist (PUnquote tm) = warnDisamb ist tm warnDisamb ist (PAs _ _ tm) = warnDisamb ist tm+warnDisamb ist (PAppImpl tm _) = warnDisamb ist tm+warnDisamb ist (PRunTactics _ tm) = warnDisamb ist tm
src/Idris/IBC.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.IBC where @@ -14,6 +15,7 @@ import qualified Idris.Docstrings as D import Idris.Docstrings (Docstring) import Idris.Output+import IRTS.System (getIdrisLibDir) import Paths_idris import qualified Cheapskate.Types as CT@@ -35,7 +37,7 @@ import Util.Zlib (decompressEither) ibcVersion :: Word8-ibcVersion = 93+ibcVersion = 100 data IBCFile = IBCFile { ver :: Word8, sourcefile :: FilePath,@@ -77,7 +79,9 @@ ibc_metavars :: ![(Name, (Maybe Name, Int, Bool))], ibc_patdefs :: ![(Name, ([([Name], Term, Term)], [PTerm]))], ibc_postulates :: ![Name],- ibc_parsedSpan :: !(Maybe FC)+ ibc_parsedSpan :: !(Maybe FC),+ ibc_usage :: ![(Name, Int)],+ ibc_exports :: ![Name] } deriving Show {-!@@ -85,11 +89,11 @@ !-} initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] -loadIBC :: Bool -- ^ True = reexport, False = make everything private +loadIBC :: Bool -- ^ True = reexport, False = make everything private -> FilePath -> Idris ()-loadIBC reexport fp +loadIBC reexport fp = do imps <- getImported let redo = case lookup fp imps of Nothing -> True@@ -102,7 +106,7 @@ -- | Load an entire package from its index file loadPkgIndex :: String -> Idris ()-loadPkgIndex pkg = do ddir <- runIO $ getDataDir+loadPkgIndex pkg = do ddir <- runIO $ getIdrisLibDir addImportDir (ddir </> pkg) fp <- findPkgIndex pkg loadIBC True fp@@ -190,7 +194,7 @@ ibc i (IBCCGFlag tgt n) f = return f { ibc_cgflags = (tgt, n) : ibc_cgflags f } ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f } ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f }-ibc i (IBCDef n) f +ibc i (IBCDef n) f = do f' <- case lookupDefExact n (tt_ctxt i) of Just v -> return f { ibc_defs = (n,v) : ibc_defs f } _ -> ifail "IBC write failed"@@ -229,17 +233,19 @@ ibc i (IBCModDocs n) f = case lookupCtxtExact n (idris_moduledocs i) of Just v -> return f { ibc_moduledocs = (n,v) : ibc_moduledocs f } _ -> 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 } process :: Bool -- ^ Reexporting -> IBCFile -> FilePath -> Idris () process reexp i fn- | ver i /= ibcVersion + | 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."- + --- please rebuild" | otherwise = do srcok <- runIO $ doesFileExist (sourcefile i)@@ -285,6 +291,8 @@ 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) timestampOlder :: FilePath -> FilePath -> Idris () timestampOlder src ibc = do srct <- runIO $ getModificationTime src@@ -302,12 +310,20 @@ pParsedSpan fc = do ist <- getIState putIState ist { idris_parsedSpan = fc } +pUsage :: [(Name, Int)] -> Idris ()+pUsage ns = do ist <- getIState+ putIState ist { idris_erasureUsed = ns ++ idris_erasureUsed ist }++pExports :: [Name] -> Idris ()+pExports ns = do ist <- getIState+ putIState ist { idris_exports = ns ++ idris_exports ist }+ pImportDirs :: [FilePath] -> Idris () pImportDirs fs = mapM_ addImportDir fs pImports :: [(Bool, FilePath)] -> Idris () pImports fs- = do mapM_ (\(re, f) -> + = do mapM_ (\(re, f) -> do i <- getIState ibcsd <- valIBCSubDir i ids <- allImportDirs@@ -349,7 +365,7 @@ -- Don't lose instances from previous IBCs, which -- could have loaded in any order let is = case lookupCtxtExact n (idris_classes i) of- Just (CI _ _ _ _ _ ins) -> ins+ Just (CI _ _ _ _ _ ins _) -> ins _ -> [] let c' = c { class_instances = class_instances c ++ is }@@ -411,20 +427,20 @@ pHdrs hs = mapM_ (uncurry addHdr) hs pPatdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))] -> Idris ()-pPatdefs ds - = mapM_ (\ (n, d) -> +pPatdefs ds+ = mapM_ (\ (n, d) -> do i <- getIState putIState (i { idris_patdefs = addDef n (force d) (idris_patdefs i) })) ds pDefs :: Bool -> [Name] -> [(Name, Def)] -> Idris ()-pDefs reexp syms ds +pDefs reexp syms ds = mapM_ (\ (n, d) -> do d' <- updateDef d case d' of- TyDecl _ _ -> return () + TyDecl _ _ -> return () _ -> do iLOG $ "SOLVING " ++ show n- solveDeferred n + solveDeferred n i <- getIState -- logLvl 1 $ "Added " ++ show (n, d') putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })@@ -493,8 +509,8 @@ pAccess :: Bool -- ^ Reexporting? -> [(Name, Accessibility)] -> Idris ()-pAccess reexp ds - = mapM_ (\ (n, a_in) -> +pAccess reexp ds+ = 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@@ -552,7 +568,7 @@ pMetavars :: [(Name, (Maybe Name, Int, Bool))] -> Idris () pMetavars ns = do i <- getIState- putIState $ i { idris_metavars = Data.List.reverse ns + putIState $ i { idris_metavars = Data.List.reverse ns ++ idris_metavars i } ----- For Cheapskate and docstrings@@ -602,6 +618,7 @@ 4 -> liftM3 D.CodeBlock get get get 5 -> liftM D.HtmlBlock get 6 -> return D.HRule+ _ -> error "Corrupted binary data for Block" instance Binary a => Binary (D.Inline a) where put (D.Str txt) = do putWord8 0 ; put txt@@ -628,6 +645,7 @@ 8 -> liftM3 D.Image get get get 9 -> liftM D.Entity get 10 -> liftM D.RawHtml get+ _ -> error "Corrupted binary data for Inline" instance Binary CT.ListType where put (CT.Bullet c) = putWord8 0 >> put c@@ -636,6 +654,7 @@ case i of 0 -> liftM CT.Bullet get 1 -> liftM2 CT.Numbered get get+ _ -> error "Corrupted binary data for ListType" instance Binary CT.CodeAttr where put (CT.CodeAttr a b) = put a >> put b@@ -648,6 +667,7 @@ case i of 0 -> return CT.PeriodFollowing 1 -> return CT.ParenFollowing+ _ -> error "Corrupted binary data for NumWrapper" ----- Generated by 'derive' @@ -778,11 +798,13 @@ return (CaseDefs x2 x2 x2 x4) instance Binary CaseInfo where- put x@(CaseInfo x1 x2) = do put x1- put x2+ put x@(CaseInfo x1 x2 x3) = do put x1+ put x2+ put x3 get = do x1 <- get x2 <- get- return (CaseInfo x1 x2)+ x3 <- get+ return (CaseInfo x1 x2 x3) instance Binary Def where put x@@ -840,7 +862,7 @@ safeToEnum label x' = result where x = fromIntegral x'- result + result | x < fromEnum (minBound `asTypeOf` result) || x > fromEnum (maxBound `asTypeOf` result) = error $ label ++ ": corrupted binary representation in IBC"@@ -858,6 +880,9 @@ put x1 NotProductive -> putWord8 5 BelieveMe -> putWord8 6+ UseUndef x1 -> do putWord8 7+ put x1+ ExternalIO -> putWord8 8 get = do i <- getWord8 case i of@@ -870,6 +895,9 @@ return (Mutual x1) 5 -> return NotProductive 6 -> return BelieveMe+ 7 -> do x1 <- get+ return (UseUndef x1)+ 8 -> return ExternalIO _ -> error "Corrupted binary data for PReason" instance Binary Totality where@@ -903,9 +931,10 @@ 0 -> return EmptyMI 1 -> do x1 <- get 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)+ 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@@ -948,6 +977,8 @@ put x39 put x40 put x41+ put x42+ put x43 get = do x1 <- get@@ -992,7 +1023,9 @@ x39 <- get x40 <- get x41 <- 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 <- 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@@ -1007,6 +1040,7 @@ 1 -> return DefaultEliminator 2 -> return DataErrRev 3 -> return DefaultCaseFun+ _ -> error "Corrupted binary data for DataOpt" instance Binary FnOpt where put x@@ -1026,6 +1060,8 @@ CoveringFn -> putWord8 11 NoImplicit -> putWord8 12 Constructor -> putWord8 13+ CExport x1 -> do putWord8 14+ put x1 get = do i <- getWord8 case i of@@ -1044,6 +1080,8 @@ 11 -> return CoveringFn 12 -> return NoImplicit 13 -> return Constructor+ 14 -> do x1 <- get+ return $ CExport x1 _ -> error "Corrupted binary data for FnOpt" instance Binary Fixity where@@ -1200,7 +1238,7 @@ put x7 put x8 put x9- PClass x1 x2 x3 x4 x5 x6 x7 x8+ PClass x1 x2 x3 x4 x5 x6 x7 x8 x9 -> do putWord8 7 put x1 put x2@@ -1210,15 +1248,19 @@ put x6 put x7 put x8- PInstance x1 x2 x3 x4 x5 x6 x7 x8 -> do putWord8 8- put x1- put x2- put x3- put x4- put x5- put x6- put x7- put x8+ put x9+ PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 ->+ do putWord8 8+ put x1+ put x2+ put x3+ put x4+ put x5+ put x6+ put x7+ put x8+ put x9+ put x10 PDSL x1 x2 -> do putWord8 9 put x1 put x2@@ -1237,6 +1279,22 @@ put x4 put x5 put x6+ PSyntax x1 x2 -> do putWord8 13+ put x1+ put x2+ PDirective x1 -> error "Cannot serialize PDirective"+ PProvider x1 x2 x3 x4 x5 ->+ do putWord8 15+ put x1+ put x2+ put x3+ put x4+ put x5+ PTransform x1 x2 x3 x4 -> do putWord8 16+ put x1+ put x2+ put x3+ put x4 get = do i <- getWord8 case i of@@ -1289,7 +1347,8 @@ x6 <- get x7 <- get x8 <- get- return (PClass x1 x2 x3 x4 x5 x6 x7 x8)+ x9 <- get+ return (PClass x1 x2 x3 x4 x5 x6 x7 x8 x9) 8 -> do x1 <- get x2 <- get x3 <- get@@ -1298,7 +1357,9 @@ x6 <- get x7 <- get x8 <- get- return (PInstance x1 x2 x3 x4 x5 x6 x7 x8)+ x9 <- get+ x10 <- get+ return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) 9 -> do x1 <- get x2 <- get return (PDSL x1 x2)@@ -1316,8 +1377,38 @@ x5 <- get x6 <- get return (PPostulate x1 x2 x3 x4 x5 x6)+ 13 -> do x1 <- get+ x2 <- get+ return (PSyntax x1 x2)+ 14 -> do error "Cannot deserialize PDirective"+ 15 -> do x1 <- get+ x2 <- get+ x3 <- get+ x4 <- get+ x5 <- get+ return (PProvider x1 x2 x3 x4 x5)+ 16 -> do x1 <- get+ x2 <- get+ x3 <- get+ x4 <- get+ return (PTransform x1 x2 x3 x4) _ -> error "Corrupted binary data for PDecl'" +instance Binary t => Binary (ProvideWhat' t) where+ put (ProvTerm x1 x2) = do putWord8 0+ put x1+ put x2+ put (ProvPostulate x1) = do putWord8 1+ put x1+ get = do y <- getWord8+ case y of+ 0 -> do x1 <- get+ x2 <- get+ return (ProvTerm x1 x2)+ 1 -> do x1 <- get+ return (ProvPostulate x1)+ _ -> error "Corrupted binary data for ProvideWhat"+ instance Binary Using where put (UImplicit x1 x2) = do putWord8 0; put x1; put x2 put (UConstraint x1 x2) = do putWord8 1; put x1; put x2@@ -1326,9 +1417,10 @@ case i of 0 -> do x1 <- get; x2 <- get; return (UImplicit x1 x2) 1 -> do x1 <- get; x2 <- get; return (UConstraint x1 x2)+ _ -> error "Corrupted binary data for Using" instance Binary SyntaxInfo where- put (Syn x1 x2 x3 x4 _ x5 x6 _ _ x7 _)+ put (Syn x1 x2 x3 x4 _ _ x5 x6 _ _ x7 _) = do put x1 put x2 put x3@@ -1344,7 +1436,7 @@ x5 <- get x6 <- get x7 <- get- return (Syn x1 x2 x3 x4 id x5 x6 Nothing 0 x7 0)+ return (Syn x1 x2 x3 x4 [] id x5 x6 Nothing 0 x7 0) instance (Binary t) => Binary (PClause' t) where put x@@ -1356,23 +1448,25 @@ put x4 put x5 put x6- PWith x1 x2 x3 x4 x5 x6 -> do putWord8 1- put x1- put x2- put x3- put x4- put x5- put x6+ PWith x1 x2 x3 x4 x5 x6 x7 -> do putWord8 1+ put x1+ put x2+ put x3+ put x4+ put x5+ put x6+ put x7 PClauseR x1 x2 x3 x4 -> do putWord8 2 put x1 put x2 put x3 put x4- PWithR x1 x2 x3 x4 -> do putWord8 3- put x1- put x2- put x3- put x4+ PWithR x1 x2 x3 x4 x5 -> do putWord8 3+ put x1+ put x2+ put x3+ put x4+ put x5 get = do i <- getWord8 case i of@@ -1389,7 +1483,8 @@ x4 <- get x5 <- get x6 <- get- return (PWith x1 x2 x3 x4 x5 x6)+ x7 <- get+ return (PWith x1 x2 x3 x4 x5 x6 x7) 2 -> do x1 <- get x2 <- get x3 <- get@@ -1399,7 +1494,8 @@ x2 <- get x3 <- get x4 <- get- return (PWithR x1 x2 x3 x4)+ x5 <- get+ return (PWithR x1 x2 x3 x4 x5) _ -> error "Corrupted binary data for PClause'" instance (Binary t) => Binary (PData' t) where@@ -1436,6 +1532,7 @@ 0 -> return TypeOrTerm 1 -> return IsType 2 -> return IsTerm+ _ -> error "Corrupted binary data for PunInfo" instance Binary PTerm where put x@@ -1470,6 +1567,7 @@ PTyped x1 x2 -> do putWord8 7 put x1 put x2+ PAppImpl x1 x2 -> error "PAppImpl in final term" PApp x1 x2 x3 -> do putWord8 8 put x1 put x2@@ -1554,7 +1652,22 @@ put x2 PUniverse x1 -> do putWord8 38 put x1+ PRunTactics x1 x2 -> do putWord8 39+ put x1+ put x2+ PAs x1 x2 x3 -> do putWord8 40+ put x1+ put x2+ put x3+ PElabError x1 -> do putWord8 41+ put x1+ PQuasiquote x1 x2 -> do putWord8 42+ put x1+ put x2+ PUnquote x1 -> do putWord8 43+ put x1 + get = do i <- getWord8 case i of@@ -1672,6 +1785,20 @@ return (PDisamb x1 x2) 38 -> do x1 <- get return (PUniverse x1)+ 39 -> do x1 <- get+ x2 <- get+ return (PRunTactics x1 x2)+ 40 -> do x1 <- get+ x2 <- get+ x3 <- get+ return (PAs x1 x2 x3)+ 41 -> do x1 <- get+ return (PElabError x1)+ 42 -> do x1 <- get+ x2 <- get+ return (PQuasiquote x1 x2)+ 43 -> do x1 <- get+ return (PUnquote x1) _ -> error "Corrupted binary data for PTerm" instance (Binary t) => Binary (PTactic' t) where@@ -1725,6 +1852,35 @@ CaseTac x1 -> do putWord8 23 put x1 SourceFC -> putWord8 24+ Intros -> putWord8 25+ Equiv x1 -> do putWord8 26+ put x1+ Claim x1 x2 -> do putWord8 27+ put x1+ put x2+ Unfocus -> putWord8 28+ MatchRefine x1 -> do putWord8 29+ put x1+ LetTacTy x1 x2 x3 -> do putWord8 30+ put x1+ put x2+ put x3+ TCInstance -> putWord8 31+ GoalType x1 x2 -> do putWord8 32+ put x1+ put x2+ TCheck x1 -> do putWord8 33+ put x1+ TEval x1 -> do putWord8 34+ put x1+ TDocStr x1 -> do putWord8 35+ put x1+ TSearch x1 -> do putWord8 36+ put x1+ Skip -> putWord8 37+ TFail x1 -> do putWord8 38+ put x1+ Abandon -> putWord8 39 get = do i <- getWord8 case i of@@ -1776,6 +1932,35 @@ 23 -> do x1 <- get return (CaseTac x1) 24 -> return SourceFC+ 25 -> return Intros+ 26 -> do x1 <- get+ return (Equiv x1)+ 27 -> do x1 <- get+ x2 <- get+ return (Claim x1 x2)+ 28 -> return Unfocus+ 29 -> do x1 <- get+ return (MatchRefine x1)+ 30 -> do x1 <- get+ x2 <- get+ x3 <- get+ return (LetTacTy x1 x2 x3)+ 31 -> return TCInstance+ 32 -> do x1 <- get+ x2 <- get+ return (GoalType x1 x2)+ 33 -> do x1 <- get+ return (TCheck x1)+ 34 -> do x1 <- get+ return (TEval x1)+ 35 -> do x1 <- get+ return (TDocStr x1)+ 36 -> do x1 <- get+ return (TSearch x1)+ 37 -> return Skip+ 38 -> do x1 <- get+ return (TFail x1)+ 39 -> return Abandon _ -> error "Corrupted binary data for PTactic'" @@ -1888,19 +2073,21 @@ instance Binary ClassInfo where- put (CI x1 x2 x3 x4 x5 _)+ put (CI x1 x2 x3 x4 x5 _ x6) = do put x1 put x2 put x3 put x4 put x5+ put x6 get = do x1 <- get x2 <- get x3 <- get x4 <- get x5 <- get- return (CI x1 x2 x3 x4 x5 [])+ x6 <- get+ return (CI x1 x2 x3 x4 x5 [] x6) instance Binary OptInfo where put (Optimise x1 x2)@@ -2023,4 +2210,3 @@ return (Via x1) 1 -> return Bytecode _ -> error "Corrupted binary data for Codegen"-
+ src/Idris/IdeMode.hs view
@@ -0,0 +1,314 @@+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}++{-# LANGUAGE FlexibleInstances, IncoherentInstances, PatternGuards #-}++module Idris.IdeMode(parseMessage, convSExp, WhatDocs(..), IdeModeCommand(..), sexpToCommand, toSExp, SExp(..), SExpable, Opt(..), ideModeEpoch, getLen, getNChar) where++import Text.Printf+import Numeric+import Data.List+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 Text.Trifecta hiding (Err)+import Text.Trifecta.Delta+import System.IO++import Idris.Core.TT+import Idris.Core.Binary++import Control.Applicative hiding (Const)++getNChar :: Handle -> Int -> String -> IO (String)+getNChar _ 0 s = return (reverse s)+getNChar h n s = do c <- hGetChar h+ getNChar h (n - 1) (c : s)++getLen :: Handle -> IO (Either Err Int)+getLen h = do s <- getNChar h 6 ""+ case readHex s of+ ((num, ""):_) -> return $ Right num+ _ -> return $ Left . Msg $ "Couldn't read length " ++ s++data SExp = SexpList [SExp]+ | StringAtom String+ | BoolAtom Bool+ | IntegerAtom Integer+ | SymbolAtom String+ deriving ( Eq, Show )++sExpToString :: SExp -> String+sExpToString (StringAtom s) = "\"" ++ escape s ++ "\""+sExpToString (BoolAtom True) = ":True"+sExpToString (BoolAtom False) = ":False"+sExpToString (IntegerAtom i) = printf "%d" i+sExpToString (SymbolAtom s) = ":" ++ s+sExpToString (SexpList l) = "(" ++ intercalate " " (map sExpToString l) ++ ")"++class SExpable a where+ toSExp :: a -> SExp++instance SExpable SExp where+ toSExp a = a++instance SExpable Bool where+ toSExp True = BoolAtom True+ toSExp False = BoolAtom False++instance SExpable String where+ toSExp s = StringAtom s++instance SExpable Integer where+ toSExp n = IntegerAtom n++instance SExpable Int where+ toSExp n = IntegerAtom (toInteger n)+++instance SExpable Name where+ toSExp s = StringAtom (show s)+++instance (SExpable a) => SExpable (Maybe a) where+ toSExp Nothing = SexpList [SymbolAtom "Nothing"]+ toSExp (Just a) = SexpList [SymbolAtom "Just", toSExp a]++instance (SExpable a) => SExpable [a] where+ toSExp l = SexpList (map toSExp l)++instance (SExpable a, SExpable b) => SExpable (a, b) where+ toSExp (l, r) = SexpList [toSExp l, toSExp r]++instance (SExpable a, SExpable b, SExpable c) => SExpable (a, b, c) where+ toSExp (l, m, n) = SexpList [toSExp l, toSExp m, toSExp n]++instance (SExpable a, SExpable b, SExpable c, SExpable d) => SExpable (a, b, c, d) where+ toSExp (l, m, n, o) = SexpList [toSExp l, toSExp m, toSExp n, toSExp o]++instance (SExpable a, SExpable b, SExpable c, SExpable d, SExpable e) =>+ SExpable (a, b, c, d, e) where+ toSExp (l, m, n, o, p) = SexpList [toSExp l, toSExp m, toSExp n, toSExp o, toSExp p]++instance SExpable NameOutput where+ toSExp TypeOutput = SymbolAtom "type"+ toSExp FunOutput = SymbolAtom "function"+ toSExp DataOutput = SymbolAtom "data"+ toSExp MetavarOutput = SymbolAtom "metavar"+ toSExp PostulateOutput = SymbolAtom "postulate"++maybeProps :: SExpable a => [(String, Maybe a)] -> [(SExp, SExp)]+maybeProps [] = []+maybeProps ((n, Just p):ps) = (SymbolAtom n, toSExp p) : maybeProps ps+maybeProps ((n, Nothing):ps) = maybeProps ps++constTy :: Const -> String+constTy (I _) = "Int"+constTy (BI _) = "Integer"+constTy (Fl _) = "Float"+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"++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)]+ toSExp (AnnBoundName n imp) = toSExp [(SymbolAtom "name", StringAtom (show n)),+ (SymbolAtom "decor", SymbolAtom "bound"),+ (SymbolAtom "implicit", BoolAtom imp)]+ toSExp (AnnConst c) = toSExp [(SymbolAtom "decor",+ SymbolAtom (if constIsType c then "type" else "data")),+ (SymbolAtom "type", StringAtom (constTy c)),+ (SymbolAtom "doc-overview", StringAtom (constDocs c)),+ (SymbolAtom "name", StringAtom (show c))]+ toSExp (AnnData ty doc) = toSExp [(SymbolAtom "decor", SymbolAtom "data"),+ (SymbolAtom "type", StringAtom ty),+ (SymbolAtom "doc-overview", StringAtom doc)]+ toSExp (AnnType name doc) = toSExp $ [(SymbolAtom "decor", SymbolAtom "type"),+ (SymbolAtom "type", StringAtom "Type"),+ (SymbolAtom "doc-overview", StringAtom doc)] +++ if not (null name) then [(SymbolAtom "name", StringAtom name)] else []+ toSExp AnnKeyword = toSExp [(SymbolAtom "decor", SymbolAtom "keyword")]+ toSExp (AnnFC fc) = toSExp [(SymbolAtom "source-loc", toSExp fc)]+ toSExp (AnnTextFmt fmt) = toSExp [(SymbolAtom "text-formatting", SymbolAtom format)]+ where format = case fmt of+ BoldText -> "bold"+ ItalicText -> "italic"+ UnderlineText -> "underline"+ toSExp (AnnTerm bnd tm) = toSExp [(SymbolAtom "tt-term", StringAtom (encodeTerm bnd tm))]+ toSExp (AnnSearchResult ordr) = toSExp [(SymbolAtom "doc-overview",+ StringAtom ("Result type is " ++ descr))]+ where descr = case ordr of+ EQ -> "isomorphic"+ LT -> "more general than searched type"+ GT -> "more specific than searched type"+ toSExp (AnnErr e) = toSExp [(SymbolAtom "error", StringAtom (encodeErr e))]++encodeTerm :: [(Name, Bool)] -> Term -> String+encodeTerm bnd tm = UTF8.toString . Base64.encode . Lazy.toStrict . Binary.encode $+ (bnd, tm)++decodeTerm :: String -> ([(Name, Bool)], Term)+decodeTerm = Binary.decode . Lazy.fromStrict . Base64.decodeLenient . UTF8.fromString++encodeErr :: Err -> String+encodeErr e = UTF8.toString . Base64.encode . Lazy.toStrict . Binary.encode $ e++decodeErr :: String -> Err+decodeErr = Binary.decode . Lazy.fromStrict . Base64.decodeLenient . UTF8.fromString++instance SExpable FC where+ toSExp (FC f (sl, sc) (el, ec)) =+ toSExp ((SymbolAtom "filename", StringAtom f),+ (SymbolAtom "start", IntegerAtom (toInteger sl), IntegerAtom (toInteger sc)),+ (SymbolAtom "end", IntegerAtom (toInteger el), IntegerAtom (toInteger ec)))++escape :: String -> String+escape = concatMap escapeChar+ where+ escapeChar '\\' = "\\\\"+ escapeChar '"' = "\\\""+ escapeChar c = [c]++pSExp = do xs <- between (char '(') (char ')') (pSExp `sepBy` (char ' '))+ return (SexpList xs)+ <|> atom++atom = do string "nil"; return (SexpList [])+ <|> do char ':'; x <- atomC; return x+ <|> do char '"'; xs <- many quotedChar; char '"'; return (StringAtom xs)+ <|> do ints <- some digit+ case readDec ints of+ ((num, ""):_) -> return (IntegerAtom (toInteger num))+ _ -> return (StringAtom ints)++atomC = do string "True"; return (BoolAtom True)+ <|> do string "False"; return (BoolAtom False)+ <|> do xs <- many (noneOf " \n\t\r\"()"); return (SymbolAtom xs)++quotedChar = try (string "\\\\" >> return '\\')+ <|> try (string "\\\"" >> return '"')+ <|> noneOf "\""++parseSExp :: String -> Result SExp+parseSExp = parseString pSExp (Directed (UTF8.fromString "(unknown)") 0 0 0 0)++data Opt = ShowImpl | ErrContext deriving Show++data WhatDocs = Overview | Full++data IdeModeCommand = REPLCompletions String+ | Interpret String+ | TypeOf String+ | CaseSplit Int String+ | AddClause Int String+ | AddProofClause Int String+ | AddMissing Int String+ | MakeWithBlock Int String+ | ProofSearch Bool Int String [String] (Maybe Int) -- ^^ Recursive?, line, name, hints, depth+ | MakeLemma Int String+ | LoadFile String (Maybe Int)+ | DocsFor String WhatDocs+ | Apropos String+ | GetOpts+ | SetOpt Opt Bool+ | Metavariables Int -- ^^ the Int is the column count for pretty-printing+ | WhoCalls String+ | CallsWho String+ | TermNormalise [(Name, Bool)] Term+ | TermShowImplicits [(Name, Bool)] Term+ | TermNoImplicits [(Name, Bool)] Term+ | TermElab [(Name, Bool)] Term+ | PrintDef String+ | ErrString Err+ | ErrPPrint Err+ | GetIdrisVersion++sexpToCommand :: SExp -> Maybe IdeModeCommand+sexpToCommand (SexpList (x:[])) = sexpToCommand x+sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd)+sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix)+sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename, IntegerAtom line]) = Just (LoadFile filename (Just (fromInteger line)))+sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename]) = Just (LoadFile filename Nothing)+sexpToCommand (SexpList [SymbolAtom "type-of", StringAtom name]) = Just (TypeOf name)+sexpToCommand (SexpList [SymbolAtom "case-split", IntegerAtom line, StringAtom name]) = Just (CaseSplit (fromInteger line) name)+sexpToCommand (SexpList [SymbolAtom "add-clause", IntegerAtom line, StringAtom name]) = Just (AddClause (fromInteger line) name)+sexpToCommand (SexpList [SymbolAtom "add-proof-clause", IntegerAtom line, StringAtom name]) = Just (AddProofClause (fromInteger line) name)+sexpToCommand (SexpList [SymbolAtom "add-missing", IntegerAtom line, StringAtom name]) = Just (AddMissing (fromInteger line) name)+sexpToCommand (SexpList [SymbolAtom "make-with", IntegerAtom line, StringAtom name]) = Just (MakeWithBlock (fromInteger line) name)+-- The Boolean in ProofSearch means "search recursively"+-- If it's False, that means "refine", i.e. apply the name and fill in any+-- arguments which can be done by unification.+sexpToCommand (SexpList (SymbolAtom "proof-search" : IntegerAtom line : StringAtom name : rest))+ | [] <- rest = Just (ProofSearch True (fromInteger line) name [] Nothing)+ | [SexpList hintexp] <- rest+ , Just hints <- getHints hintexp = Just (ProofSearch True (fromInteger line) name hints Nothing)+ | [SexpList hintexp, IntegerAtom depth] <- rest+ , Just hints <- getHints hintexp = Just (ProofSearch True (fromInteger line) name hints (Just (fromInteger depth)))+ where getHints = mapM (\h -> case h of+ StringAtom s -> Just s+ _ -> Nothing)+sexpToCommand (SexpList [SymbolAtom "make-lemma", IntegerAtom line, StringAtom name]) = Just (MakeLemma (fromInteger line) name)+sexpToCommand (SexpList [SymbolAtom "refine", IntegerAtom line, StringAtom name, StringAtom hint]) = Just (ProofSearch False (fromInteger line) name [hint] Nothing)+sexpToCommand (SexpList [SymbolAtom "docs-for", StringAtom name]) = Just (DocsFor name Full)+sexpToCommand (SexpList [SymbolAtom "docs-for", StringAtom name, SymbolAtom s])+ | Just w <- lookup s opts = Just (DocsFor name w)+ where opts = [("overview", Overview), ("full", Full)]+sexpToCommand (SexpList [SymbolAtom "apropos", StringAtom search]) = Just (Apropos search)+sexpToCommand (SymbolAtom "get-options") = Just GetOpts+sexpToCommand (SexpList [SymbolAtom "set-option", SymbolAtom s, BoolAtom b])+ | Just opt <- lookup s opts = Just (SetOpt opt b)+ where opts = [("show-implicits", ShowImpl), ("error-context", ErrContext)] --TODO support more options. Issue #1611 in the Issue tracker. https://github.com/idris-lang/Idris-dev/issues/1611+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 "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+ Just (TermShowImplicits bnd tm)+sexpToCommand (SexpList [SymbolAtom "hide-term-implicits", StringAtom encoded]) = let (bnd, tm) = decodeTerm encoded in+ Just (TermNoImplicits bnd tm)+sexpToCommand (SexpList [SymbolAtom "elaborate-term", StringAtom encoded]) = let (bnd, tm) = decodeTerm encoded in+ Just (TermElab bnd tm)+sexpToCommand (SexpList [SymbolAtom "print-definition", StringAtom name]) = Just (PrintDef name)+sexpToCommand (SexpList [SymbolAtom "error-string", StringAtom encoded]) = Just . ErrString . decodeErr $ encoded+sexpToCommand (SexpList [SymbolAtom "error-pprint", StringAtom encoded]) = Just . ErrPPrint . decodeErr $ encoded+sexpToCommand (SymbolAtom "version") = Just GetIdrisVersion+sexpToCommand _ = Nothing++parseMessage :: String -> Either Err (SExp, Integer)+parseMessage x = case receiveString x of+ Right (SexpList [cmd, (IntegerAtom id)]) -> Right (cmd, id)+ Right x -> Left . Msg $ "Invalid message " ++ show x+ Left err -> Left err++receiveString :: String -> Either Err SExp+receiveString x =+ case parseSExp x of+ Failure _ -> Left . Msg $ "parse failure"+ Success r -> Right r++convSExp :: SExpable a => String -> a -> Integer -> String+convSExp pre s id =+ let sex = SexpList [SymbolAtom pre, toSExp s, IntegerAtom id] in+ let str = sExpToString sex in+ (getHexLength str) ++ str++getHexLength :: String -> String+getHexLength s = printf "%06x" (1 + (length s))++-- | The version of the IDE mode command set. Increment this when you+-- change it so clients can adapt.+ideModeEpoch :: Int+ideModeEpoch = 1
− src/Idris/IdeSlave.hs
@@ -1,302 +0,0 @@-{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}--{-# LANGUAGE FlexibleInstances, IncoherentInstances, PatternGuards #-}--module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..), SExpable, Opt(..), ideSlaveEpoch, getLen, getNChar) where--import Text.Printf-import Numeric-import Data.List-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 Text.Trifecta hiding (Err)-import Text.Trifecta.Delta-import System.IO--import Idris.Core.TT-import Idris.Core.Binary--import Control.Applicative hiding (Const)--getNChar :: Handle -> Int -> String -> IO (String)-getNChar _ 0 s = return (reverse s)-getNChar h n s = do c <- hGetChar h- getNChar h (n - 1) (c : s)--getLen :: Handle -> IO (Either Err Int)-getLen h = do s <- getNChar h 6 ""- case readHex s of- ((num, ""):_) -> return $ Right num- _ -> return $ Left . Msg $ "Couldn't read length " ++ s--data SExp = SexpList [SExp]- | StringAtom String- | BoolAtom Bool- | IntegerAtom Integer- | SymbolAtom String- deriving ( Eq, Show )--sExpToString :: SExp -> String-sExpToString (StringAtom s) = "\"" ++ escape s ++ "\""-sExpToString (BoolAtom True) = ":True"-sExpToString (BoolAtom False) = ":False"-sExpToString (IntegerAtom i) = printf "%d" i-sExpToString (SymbolAtom s) = ":" ++ s-sExpToString (SexpList l) = "(" ++ intercalate " " (map sExpToString l) ++ ")"--class SExpable a where- toSExp :: a -> SExp--instance SExpable SExp where- toSExp a = a--instance SExpable Bool where- toSExp True = BoolAtom True- toSExp False = BoolAtom False--instance SExpable String where- toSExp s = StringAtom s--instance SExpable Integer where- toSExp n = IntegerAtom n--instance SExpable Int where- toSExp n = IntegerAtom (toInteger n)---instance SExpable Name where- toSExp s = StringAtom (show s)---instance (SExpable a) => SExpable (Maybe a) where- toSExp Nothing = SexpList [SymbolAtom "Nothing"]- toSExp (Just a) = SexpList [SymbolAtom "Just", toSExp a]--instance (SExpable a) => SExpable [a] where- toSExp l = SexpList (map toSExp l)--instance (SExpable a, SExpable b) => SExpable (a, b) where- toSExp (l, r) = SexpList [toSExp l, toSExp r]--instance (SExpable a, SExpable b, SExpable c) => SExpable (a, b, c) where- toSExp (l, m, n) = SexpList [toSExp l, toSExp m, toSExp n]--instance (SExpable a, SExpable b, SExpable c, SExpable d) => SExpable (a, b, c, d) where- toSExp (l, m, n, o) = SexpList [toSExp l, toSExp m, toSExp n, toSExp o]--instance (SExpable a, SExpable b, SExpable c, SExpable d, SExpable e) =>- SExpable (a, b, c, d, e) where- toSExp (l, m, n, o, p) = SexpList [toSExp l, toSExp m, toSExp n, toSExp o, toSExp p]--instance SExpable NameOutput where- toSExp TypeOutput = SymbolAtom "type"- toSExp FunOutput = SymbolAtom "function"- toSExp DataOutput = SymbolAtom "data"- toSExp MetavarOutput = SymbolAtom "metavar"- toSExp PostulateOutput = SymbolAtom "postulate"--maybeProps :: SExpable a => [(String, Maybe a)] -> [(SExp, SExp)]-maybeProps [] = []-maybeProps ((n, Just p):ps) = (SymbolAtom n, toSExp p) : maybeProps ps-maybeProps ((n, Nothing):ps) = maybeProps ps--constTy :: Const -> String-constTy (I _) = "Int"-constTy (BI _) = "Integer"-constTy (Fl _) = "Float"-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"--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)]- toSExp (AnnBoundName n imp) = toSExp [(SymbolAtom "name", StringAtom (show n)),- (SymbolAtom "decor", SymbolAtom "bound"),- (SymbolAtom "implicit", BoolAtom imp)]- toSExp (AnnConst c) = toSExp [(SymbolAtom "decor",- SymbolAtom (if constIsType c then "type" else "data")),- (SymbolAtom "type", StringAtom (constTy c)),- (SymbolAtom "doc-overview", StringAtom (constDocs c)),- (SymbolAtom "name", StringAtom (show c))]- toSExp (AnnData ty doc) = toSExp [(SymbolAtom "decor", SymbolAtom "data"),- (SymbolAtom "type", StringAtom ty),- (SymbolAtom "doc-overview", StringAtom doc)]- toSExp (AnnType name doc) = toSExp $ [(SymbolAtom "decor", SymbolAtom "type"),- (SymbolAtom "type", StringAtom "Type"),- (SymbolAtom "doc-overview", StringAtom doc)] ++- if not (null name) then [(SymbolAtom "name", StringAtom name)] else []- toSExp AnnKeyword = toSExp [(SymbolAtom "decor", SymbolAtom "keyword")]- toSExp (AnnFC fc) = toSExp [(SymbolAtom "source-loc", toSExp fc)]- toSExp (AnnTextFmt fmt) = toSExp [(SymbolAtom "text-formatting", SymbolAtom format)]- where format = case fmt of- BoldText -> "bold"- ItalicText -> "italic"- UnderlineText -> "underline"- toSExp (AnnTerm bnd tm) = toSExp [(SymbolAtom "tt-term", StringAtom (encodeTerm bnd tm))]- toSExp (AnnSearchResult ordr) = toSExp [(SymbolAtom "doc-overview",- StringAtom ("Result type is " ++ descr))]- where descr = case ordr of- EQ -> "isomorphic"- LT -> "more general than searched type"- GT -> "more specific than searched type"- toSExp (AnnErr e) = toSExp [(SymbolAtom "error", StringAtom (encodeErr e))]--encodeTerm :: [(Name, Bool)] -> Term -> String-encodeTerm bnd tm = UTF8.toString . Base64.encode . Lazy.toStrict . Binary.encode $- (bnd, tm)--decodeTerm :: String -> ([(Name, Bool)], Term)-decodeTerm = Binary.decode . Lazy.fromStrict . Base64.decodeLenient . UTF8.fromString--encodeErr :: Err -> String-encodeErr e = UTF8.toString . Base64.encode . Lazy.toStrict . Binary.encode $ e--decodeErr :: String -> Err-decodeErr = Binary.decode . Lazy.fromStrict . Base64.decodeLenient . UTF8.fromString--instance SExpable FC where- toSExp (FC f (sl, sc) (el, ec)) =- toSExp ((SymbolAtom "filename", StringAtom f),- (SymbolAtom "start", IntegerAtom (toInteger sl), IntegerAtom (toInteger sc)),- (SymbolAtom "end", IntegerAtom (toInteger el), IntegerAtom (toInteger ec)))--escape :: String -> String-escape = concatMap escapeChar- where- escapeChar '\\' = "\\\\"- escapeChar '"' = "\\\""- escapeChar c = [c]--pSExp = do xs <- between (char '(') (char ')') (pSExp `sepBy` (char ' '))- return (SexpList xs)- <|> atom--atom = do string "nil"; return (SexpList [])- <|> do char ':'; x <- atomC; return x- <|> do char '"'; xs <- many quotedChar; char '"'; return (StringAtom xs)- <|> do ints <- some digit- case readDec ints of- ((num, ""):_) -> return (IntegerAtom (toInteger num))- _ -> return (StringAtom ints)--atomC = do string "True"; return (BoolAtom True)- <|> do string "False"; return (BoolAtom False)- <|> do xs <- many (noneOf " \n\t\r\"()"); return (SymbolAtom xs)--quotedChar = try (string "\\\\" >> return '\\')- <|> try (string "\\\"" >> return '"')- <|> noneOf "\""--parseSExp :: String -> Result SExp-parseSExp = parseString pSExp (Directed (UTF8.fromString "(unknown)") 0 0 0 0)--data Opt = ShowImpl | ErrContext deriving Show--data IdeSlaveCommand = REPLCompletions String- | Interpret String- | TypeOf String- | CaseSplit Int String- | AddClause Int String- | AddProofClause Int String- | AddMissing Int String- | MakeWithBlock Int String- | ProofSearch Bool Int String [String] (Maybe Int) -- ^^ Recursive?, line, name, hints, depth- | MakeLemma Int String- | LoadFile String (Maybe Int)- | DocsFor String- | Apropos String- | GetOpts- | SetOpt Opt Bool- | Metavariables Int -- ^^ the Int is the column count for pretty-printing- | WhoCalls String- | CallsWho String- | TermNormalise [(Name, Bool)] Term- | TermShowImplicits [(Name, Bool)] Term- | TermNoImplicits [(Name, Bool)] Term- | PrintDef String- | ErrString Err- | ErrPPrint Err--sexpToCommand :: SExp -> Maybe IdeSlaveCommand-sexpToCommand (SexpList (x:[])) = sexpToCommand x-sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd)-sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix)-sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename, IntegerAtom line]) = Just (LoadFile filename (Just (fromInteger line)))-sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename]) = Just (LoadFile filename Nothing)-sexpToCommand (SexpList [SymbolAtom "type-of", StringAtom name]) = Just (TypeOf name)-sexpToCommand (SexpList [SymbolAtom "case-split", IntegerAtom line, StringAtom name]) = Just (CaseSplit (fromInteger line) name)-sexpToCommand (SexpList [SymbolAtom "add-clause", IntegerAtom line, StringAtom name]) = Just (AddClause (fromInteger line) name)-sexpToCommand (SexpList [SymbolAtom "add-proof-clause", IntegerAtom line, StringAtom name]) = Just (AddProofClause (fromInteger line) name)-sexpToCommand (SexpList [SymbolAtom "add-missing", IntegerAtom line, StringAtom name]) = Just (AddMissing (fromInteger line) name)-sexpToCommand (SexpList [SymbolAtom "make-with", IntegerAtom line, StringAtom name]) = Just (MakeWithBlock (fromInteger line) name)--- The Boolean in ProofSearch means "search recursively"--- If it's False, that means "refine", i.e. apply the name and fill in any--- arguments which can be done by unification.-sexpToCommand (SexpList (SymbolAtom "proof-search" : IntegerAtom line : StringAtom name : rest))- | [] <- rest = Just (ProofSearch True (fromInteger line) name [] Nothing)- | [SexpList hintexp] <- rest- , Just hints <- getHints hintexp = Just (ProofSearch True (fromInteger line) name hints Nothing)- | [SexpList hintexp, IntegerAtom depth] <- rest- , Just hints <- getHints hintexp = Just (ProofSearch True (fromInteger line) name hints (Just (fromInteger depth)))- where getHints = mapM (\h -> case h of- StringAtom s -> Just s- _ -> Nothing)-sexpToCommand (SexpList [SymbolAtom "make-lemma", IntegerAtom line, StringAtom name]) = Just (MakeLemma (fromInteger line) name)-sexpToCommand (SexpList [SymbolAtom "refine", IntegerAtom line, StringAtom name, StringAtom hint]) = Just (ProofSearch False (fromInteger line) name [hint] Nothing)-sexpToCommand (SexpList [SymbolAtom "docs-for", StringAtom name]) = Just (DocsFor name)-sexpToCommand (SexpList [SymbolAtom "apropos", StringAtom search]) = Just (Apropos search)-sexpToCommand (SymbolAtom "get-options") = Just GetOpts-sexpToCommand (SexpList [SymbolAtom "set-option", SymbolAtom s, BoolAtom b])- | Just opt <- lookup s opts = Just (SetOpt opt b)- where opts = [("show-implicits", ShowImpl), ("error-context", ErrContext)] --TODO support more options. Issue #1611 in the Issue tracker. https://github.com/idris-lang/Idris-dev/issues/1611-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 "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- Just (TermShowImplicits bnd tm)-sexpToCommand (SexpList [SymbolAtom "hide-term-implicits", StringAtom encoded]) = let (bnd, tm) = decodeTerm encoded in- Just (TermNoImplicits bnd tm)-sexpToCommand (SexpList [SymbolAtom "print-definition", StringAtom name]) = Just (PrintDef name)-sexpToCommand (SexpList [SymbolAtom "error-string", StringAtom encoded]) = Just . ErrString . decodeErr $ encoded-sexpToCommand (SexpList [SymbolAtom "error-pprint", StringAtom encoded]) = Just . ErrPPrint . decodeErr $ encoded-sexpToCommand _ = Nothing--parseMessage :: String -> Either Err (SExp, Integer)-parseMessage x = case receiveString x of- Right (SexpList [cmd, (IntegerAtom id)]) -> Right (cmd, id)- Right x -> Left . Msg $ "Invalid message " ++ show x- Left err -> Left err--receiveString :: String -> Either Err SExp-receiveString x =- case parseSExp x of- Failure _ -> Left . Msg $ "parse failure"- Success r -> Right r--convSExp :: SExpable a => String -> a -> Integer -> String-convSExp pre s id =- let sex = SexpList [SymbolAtom pre, toSExp s, IntegerAtom id] in- let str = sExpToString sex in- (getHexLength str) ++ str--getHexLength :: String -> String-getHexLength s = printf "%06x" (1 + (length s))--ideSlaveEpoch :: Int-ideSlaveEpoch = 1
src/Idris/IdrisDoc.hs view
@@ -168,7 +168,7 @@ in filter ((`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 (Just (ClassDoc _ _ fds _ _ _ _)) = map (\(FD n _ _ _ _) -> n) fds names _ = [] -- | Whether a Name names something which should be documented@@ -219,7 +219,7 @@ where getFunDocs (FunDoc f) = [f] getFunDocs (DataDoc f fs) = f:fs- getFunDocs (ClassDoc _ _ fs _ _ _) = fs+ getFunDocs (ClassDoc _ _ fs _ _ _ _) = fs types (FD _ _ args t _) = t:(map second args) second (_, x, _, _) = x @@ -273,7 +273,7 @@ -> Name -- ^ Name to load Docs for -> IO (Maybe Docs) loadDocs ist n- | mayHaveDocs n = do docs <- runExceptT $ evalStateT (getDocs n) ist+ | mayHaveDocs n = do docs <- runExceptT $ evalStateT (getDocs n FullDocs) ist case docs of Right d -> return (Just d) Left _ -> return Nothing | otherwise = return Nothing@@ -318,6 +318,7 @@ extractPTermNames (PDisamb _ p) = extract p extractPTermNames (PUnifyLog p) = extract p extractPTermNames (PNoImplicits p) = extract p+extractPTermNames (PRunTactics _ p) = extract p extractPTermNames _ = [] -- | Shorter name for extractPTermNames@@ -416,7 +417,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@@ -438,7 +439,7 @@ createNsDoc ist ns content out = do let tpath = out </> "docs" </> (genRelNsPath ns "html") dir = takeDirectory tpath- file = takeFileName tpath + file = takeFileName tpath haveDocs (_, Just d, _) = [d] haveDocs _ = [] -- We cannot do anything without a Doc@@ -574,7 +575,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 _ _ _ _) = do H.dt ! (A.id $ toValue $ show n) $ do H.span ! class_ "word" $ do "class"; nbsp H.span ! class_ "name type"
src/Idris/Imports.hs view
@@ -44,7 +44,7 @@ ibcPathWithFallback :: FilePath -> FilePath -> IO FilePath ibcPathWithFallback ibcsd fp = do let ibcp = ibcPath ibcsd True fp- ibc <- doesFileExist ibcp+ ibc <- doesFileExist' ibcp return (if ibc then ibcp else ibcPath ibcsd False fp)@@ -58,9 +58,9 @@ ibcp <- runIO $ ibcPathWithFallback ibcsd fp_full let idrp = srcPath fp_full let lidrp = lsrcPath fp_full- ibc <- runIO $ doesFileExist ibcp- idr <- runIO $ doesFileExist idrp- lidr <- runIO $ doesFileExist lidrp+ ibc <- runIO $ doesFileExist' ibcp+ idr <- runIO $ doesFileExist' idrp+ lidr <- runIO $ doesFileExist' lidrp -- when idr $ putStrLn $ idrp ++ " ok" -- when lidr $ putStrLn $ lidrp ++ " ok" -- when ibc $ putStrLn $ ibcp ++ " ok"@@ -78,7 +78,7 @@ findInPath :: [FilePath] -> FilePath -> IO FilePath findInPath [] fp = fail $ "Can't find file " ++ fp findInPath (d:ds) fp = do let p = d </> fp- e <- doesFileExist p+ e <- doesFileExist' p if e then return p else findInPath ds fp findPkgIndex :: String -> Idris FilePath@@ -94,10 +94,26 @@ where allFilesInDir base fp = do let fullpath = base </> fp- isDir <- doesDirectoryExist fullpath+ isDir <- doesDirectoryExist' fullpath if isDir then fmap concat (mapM (allFilesInDir fullpath) =<< dirContents fullpath) else return [fp] dirContents = fmap (filter (not . (`elem` [".", ".."]))) . getDirectoryContents goodDir idir d = any (".ibc" `isSuffixOf`) <$> allFilesInDir idir d ++-- Case sensitive file existence check for Mac OS X.+doesFileExist' :: FilePath -> IO Bool+doesFileExist' = caseSensitive doesFileExist++-- Case sensitive directory existence check for Mac OS X.+doesDirectoryExist' :: FilePath -> IO Bool+doesDirectoryExist' = caseSensitive doesDirectoryExist++caseSensitive :: (FilePath -> IO Bool) -> FilePath -> IO Bool+caseSensitive existsCheck name =+ do exists <- existsCheck name+ if exists+ then do contents <- getDirectoryContents (takeDirectory name)+ return $ (takeFileName name) `elem` contents+ else return False
src/Idris/Interactive.hs view
@@ -16,7 +16,7 @@ import Idris.Error import Idris.Delaborate import Idris.Output-import Idris.IdeSlave hiding (IdeSlaveCommand(..))+import Idris.IdeMode hiding (IdeModeCommand(..)) import Idris.Elab.Value @@ -271,7 +271,7 @@ runIO $ copyFile fb fn else case idris_outputmode i of RawOutput _ -> iPrintResult $ lem ++ "\n" ++ lem_app- IdeSlave n h ->+ IdeMode n h -> let good = SexpList [SymbolAtom "ok", SexpList [SymbolAtom "metavariable-lemma", SexpList [SymbolAtom "replace-metavariable",@@ -289,7 +289,7 @@ runIO $ copyFile fb fn else case idris_outputmode i of RawOutput _ -> iPrintResult $ lem_app- IdeSlave n h ->+ IdeMode n h -> let good = SexpList [SymbolAtom "ok", SexpList [SymbolAtom "provisional-definition-lemma", SexpList [SymbolAtom "definition-clause",
src/Idris/Output.hs view
@@ -8,12 +8,12 @@ import Idris.AbsSyntax import Idris.Delaborate import Idris.Docstrings-import Idris.IdeSlave+import Idris.IdeMode import Util.Pretty import Util.ScreenSize (getScreenWidth) -import Control.Monad.Except (ExceptT (ExceptT), runExceptT, throwError)+import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) import System.Console.Haskeline.MonadException (MonadException (controlIO), RunIO (RunIO))@@ -43,7 +43,7 @@ then text (show fc) <> colon <//> err else err runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'- IdeSlave n h ->+ IdeMode n h -> do err' <- iRender . fmap (fancifyAnnots i) $ err let (str, spans) = displaySpans err' runIO . hPutStrLn h $@@ -52,8 +52,8 @@ iRender :: Doc a -> Idris (SimpleDoc a) iRender d = do w <- getWidth ist <- getIState- let ideSlave = case idris_outputmode ist of- IdeSlave _ _ -> True+ let ideMode = case idris_outputmode ist of+ IdeMode _ _ -> True _ -> False case w of InfinitelyWide -> return $ renderPretty 1.0 1000000000 d@@ -61,7 +61,7 @@ if n < 1 then renderPretty 1.0 1000000000 d else renderPretty 0.8 n d- AutomaticWidth | ideSlave -> return $ renderPretty 1.0 1000000000 d+ AutomaticWidth | ideMode -> return $ renderPretty 1.0 80 d | otherwise -> do width <- runIO getScreenWidth return $ renderPretty 0.8 width d @@ -76,7 +76,7 @@ iPrintTermWithType :: Doc OutputAnnotation -> Doc OutputAnnotation -> Idris () iPrintTermWithType tm ty = iRenderResult (tm <+> colon <+> align ty) --- | Pretty-print a collection of overloadings to REPL or IDESlave - corresponds to :t name+-- | Pretty-print a collection of overloadings to REPL or IDEMode - corresponds to :t name iPrintFunTypes :: [(Name, Bool)] -> Name -> [(Name, Doc OutputAnnotation)] -> Idris () iPrintFunTypes bnd n [] = iPrintError $ "No such variable " ++ show n iPrintFunTypes bnd n overloads = do ist <- getIState@@ -94,7 +94,7 @@ case idris_outputmode i of RawOutput h -> do out <- iRender doc runIO $ putStrLn (displayDecorated (consoleDecorate i) out)- IdeSlave n h ->+ IdeMode n h -> do (str, spans) <- fmap displaySpans . iRender . fmap (fancifyAnnots i) $ doc let out = [toSExp str, toSExp spans] runIO . hPutStrLn h $ convSExp "write-decorated" out n@@ -103,10 +103,10 @@ iRenderResult d = do ist <- getIState case idris_outputmode ist of RawOutput h -> consoleDisplayAnnotated h d- IdeSlave n h -> ideSlaveReturnAnnotated n h d+ IdeMode n h -> ideModeReturnAnnotated n h d -ideSlaveReturnWithStatus :: String -> Integer -> Handle -> Doc OutputAnnotation -> Idris ()-ideSlaveReturnWithStatus status n h out = do+ideModeReturnWithStatus :: String -> Integer -> Handle -> Doc OutputAnnotation -> Idris ()+ideModeReturnWithStatus status n h out = do ist <- getIState (str, spans) <- fmap displaySpans . iRender .@@ -116,16 +116,16 @@ runIO . hPutStrLn h $ convSExp "return" good n --- | Write pretty-printed output to IDESlave with semantic annotations-ideSlaveReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()-ideSlaveReturnAnnotated = ideSlaveReturnWithStatus "ok"+-- | Write pretty-printed output to IDEMode with semantic annotations+ideModeReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()+ideModeReturnAnnotated = ideModeReturnWithStatus "ok" -- | Show an error with semantic highlighting iRenderError :: Doc OutputAnnotation -> Idris () iRenderError e = do ist <- getIState case idris_outputmode ist of RawOutput h -> consoleDisplayAnnotated h e- IdeSlave n h -> ideSlaveReturnWithStatus "error" n h e+ IdeMode n h -> ideModeReturnWithStatus "error" n h e iPrintWithStatus :: String -> String -> Idris () iPrintWithStatus status s = do@@ -134,7 +134,7 @@ RawOutput h -> case s of "" -> return () s -> runIO $ hPutStrLn h s- IdeSlave n h ->+ IdeMode n h -> let good = SexpList [SymbolAtom status, toSExp s] in runIO $ hPutStrLn h $ convSExp "return" good n @@ -149,21 +149,23 @@ iputStrLn s = do i <- getIState case idris_outputmode i of RawOutput h -> runIO $ hPutStrLn h s- IdeSlave n h -> runIO . hPutStrLn h $ convSExp "write-string" s n+ IdeMode n h -> runIO . hPutStrLn h $ convSExp "write-string" s n -ideslavePutSExp :: SExpable a => String -> a -> Idris ()-ideslavePutSExp cmd info = do i <- getIState- case idris_outputmode i of- IdeSlave n h -> runIO . hPutStrLn h $ convSExp cmd info n- _ -> return ()+idemodePutSExp :: SExpable a => String -> a -> Idris ()+idemodePutSExp cmd info = do i <- getIState+ case idris_outputmode i of+ IdeMode n h ->+ runIO . hPutStrLn h $+ convSExp cmd info n+ _ -> return () -- TODO: send structured output similar to the metavariable list iputGoal :: SimpleDoc OutputAnnotation -> Idris () iputGoal g = do i <- getIState case idris_outputmode i of RawOutput h -> runIO $ hPutStrLn h (displayDecorated (consoleDecorate i) g)- IdeSlave n h ->+ IdeMode n h -> let (str, spans) = displaySpans . fmap (fancifyAnnots i) $ g goal = [toSExp str, toSExp spans] in runIO . hPutStrLn h $ convSExp "write-goal" goal n
src/Idris/ParseExpr.hs view
@@ -221,6 +221,7 @@ internalExpr :: SyntaxInfo -> IdrisParser PTerm internalExpr syn = unifyLog syn+ <|> runTactics syn <|> disamb syn <|> noImplicits syn <|> recordType syn@@ -487,6 +488,19 @@ return (PUnifyLog tm) <?> "unification log expression" +{- | Parses a new-style tactics expression+RunTactics ::=+ '%' 'runTactics' 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"+ {- | Parses a disambiguation expression Disamb ::= '%' 'disamb' NameList Expr@@ -526,41 +540,22 @@ @ -} app :: SyntaxInfo -> IdrisParser PTerm-app syn = do f <- reserved "mkForeign"+app syn = do f <- simpleExpr syn+ (do try $ reservedOp "<=="+ fc <- getFC+ ff <- fnName+ return (PLet fc (sMN 0 "match")+ f+ (PMatchApp fc ff)+ (PRef fc (sMN 0 "match")))+ <?> "matching application expression") <|> (do fc <- getFC- fn <- arg syn- args <- many (do notEndApp; arg syn) i <- get- let ap = PApp fc (PRef fc (sUN "liftPrimIO"))- [pexp (PLam fc (sMN 0 "w")- Placeholder- (PApp fc (PRef fc (sUN "mkForeignPrim"))- (fn : args ++- [pexp (PRef fc (sMN 0 "w"))])))]- return (dslify i ap)-- <|> do f <- simpleExpr syn- (do try $ reservedOp "<=="- fc <- getFC- ff <- fnName- return (PLet fc (sMN 0 "match")- f- (PMatchApp fc ff)- (PRef fc (sMN 0 "match")))- <?> "matching application expression") <|> (do- fc <- getFC- i <- get- args <- many (do notEndApp; arg syn)- case args of- [] -> return f- _ -> return (dslify i (PApp fc f args)))+ args <- many (do notEndApp; arg syn)+ case args of+ [] -> return f+ _ -> return (PApp fc f args)) <?> "function application"- where- dslify :: IState -> PTerm -> PTerm- dslify i (PApp fc (PRef _ f) [a])- | [d] <- lookupCtxt f (idris_dsls i)- = desugar (syn { dsl_info = d }) i (getTm a)- dslify i t = t {-| Parses a function argument @@@ -868,7 +863,7 @@ 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 lazy or static"+ when (st == Static) $ fail "auto type constraints can not be static" xt <- typeDeclList syn lchar '}' symbol "->"@@ -876,8 +871,10 @@ 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 lazy or static"- script <- simpleExpr syn+ 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 "->"@@ -1163,6 +1160,8 @@ , ("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)))@@ -1262,10 +1261,15 @@ [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name) do ns <- sepBy (spaced name) (lchar ','); return $ Intro ns) , noArgs ["intros"] Intros+ , noArgs ["unfocus"] Unfocus , (["refine"], Just ExprTArg, const $ do n <- spaced fnName imps <- many imp return $ Refine n imps)+ , (["claim"], Nothing, \syn ->+ do n <- indentPropHolds gtProp *> name+ goal <- indentPropHolds gtProp *> expr syn+ return $ Claim n goal) , (["mrefine"], Just ExprTArg, const $ do n <- spaced fnName return $ MatchRefine n)@@ -1340,7 +1344,7 @@ tactic :: SyntaxInfo -> IdrisParser PTactic-tactic syn = choice [ do choice (map reserved names); parser syn +tactic syn = choice [ do choice (map reserved names); parser syn | (names, _, parser) <- tactics ] <|> do lchar '{' t <- tactic syn;
src/Idris/ParseHelpers.hs view
@@ -105,22 +105,20 @@ isEol '\n' = True isEol _ = False +-- | A parser that succeeds at the end of the line eol :: MonadicParsing m => m () eol = (satisfy isEol *> pure ()) <|> lookAhead eof <?> "end of line" {- | Consumes a single-line comment @- SingleLineComment_t ::= '--' EOL_t- | '--' ~DocCommentMarker_t ~EOL_t* EOL_t- ;+ SingleLineComment_t ::= '--' ~EOL_t* EOL_t ; @ -} singleLineComment :: MonadicParsing m => m ()-singleLineComment = try (string "--" *> eol *> pure ())- <|> try (string "--" *> many simpleWhiteSpace *>- many (satisfy (not . isEol)) *>- eol *> pure ())+singleLineComment = (string "--" *>+ many (satisfy (not . isEol)) *>+ eol *> pure ()) <?> "" {- | Consumes a multi-line comment@@ -128,7 +126,7 @@ @ MultiLineComment_t ::= '{ -- }'- | '{ -' ~DocCommentMarker_t InCommentChars_t+ | '{ -' InCommentChars_t ; @ @@ -154,7 +152,7 @@ startEnd :: String startEnd = "{}-" -{-| Parses a documentation comment (similar to haddock) given a marker character+{-| Parses a documentation comment @ DocComment_t ::= '|||' ~EOL_t* EOL_t@@ -224,7 +222,7 @@ idrisStyle :: MonadicParsing m => IdentifierStyle m idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved Hi.Identifier Hi.ReservedIdentifier where _styleName = "Idris"- _styleStart = satisfy isAlpha+ _styleStart = satisfy isAlpha <|> oneOf "_" _styleLetter = satisfy isAlphaNum <|> oneOf "_'." _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "Type", "do", "dsl", "import", "impossible",@@ -262,7 +260,9 @@ -- | Parses an identifier as a token identifier :: MonadicParsing m => m String-identifier = token $ Tok.ident idrisStyle+identifier = try(do i <- token $ Tok.ident idrisStyle+ when (i == "_") $ unexpected "wildcard"+ return i) -- | Parses an identifier with possible namespace as a name iName :: MonadicParsing m => [String] -> m Name@@ -321,10 +321,17 @@ operatorLetter :: MonadicParsing m => m Char operatorLetter = oneOf opChars ++commentMarkers :: [String]+commentMarkers = [ "--", "|||" ]++invalidOperators :: [String]+invalidOperators = [":", "=>", "->", "<-", "=", "?=", "|", "**", "==>", "\\", "%", "~", "?", "!"]+ -- | Parses an operator operator :: MonadicParsing m => m String operator = do op <- token . some $ operatorLetter- when (op `elem` [":", "=>", "->", "<-", "=", "?=", "|"]) $+ when (op `elem` (invalidOperators ++ commentMarkers)) $ fail $ op ++ " is not a valid operator" return op @@ -562,25 +569,25 @@ where clauses :: Maybe Name -> [PClause] -> [PDecl] -> [PDecl] clauses j@(Just n) acc (PClauses fc _ _ [PClause fc' n' l ws r w] : ds) | n == n' = clauses j (PClause fc' n' l ws r (collect w) : acc) ds- clauses j@(Just n) acc (PClauses fc _ _ [PWith fc' n' l ws r w] : ds)- | n == n' = clauses j (PWith fc' n' l ws r (collect w) : acc) ds+ clauses j@(Just n) acc (PClauses fc _ _ [PWith fc' n' l ws r pn w] : ds)+ | n == n' = clauses j (PWith fc' n' l ws r pn (collect w) : acc) ds clauses (Just n) acc xs = PClauses (fcOf c) o n (reverse acc) : collect xs clauses Nothing acc (x:xs) = collect xs clauses Nothing acc [] = [] cname :: PDecl -> Maybe Name cname (PClauses fc _ _ [PClause _ n _ _ _ _]) = Just n- cname (PClauses fc _ _ [PWith _ n _ _ _ _]) = Just n+ cname (PClauses fc _ _ [PWith _ n _ _ _ _ _]) = Just n cname (PClauses fc _ _ [PClauseR _ _ _ _]) = Nothing- cname (PClauses fc _ _ [PWithR _ _ _ _]) = Nothing+ cname (PClauses fc _ _ [PWithR _ _ _ _ _]) = Nothing fcOf :: PDecl -> FC fcOf (PClauses fc _ _ _) = fc collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds collect (PNamespace ns ps : ds) = PNamespace ns (collect ps) : collect ds-collect (PClass doc f s cs n ps pdocs ds : ds')- = PClass doc f s cs n ps pdocs (collect ds) : collect ds'-collect (PInstance f s cs n ps t en ds : ds')- = PInstance f s cs n ps t en (collect ds) : collect ds'+collect (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 (d : ds) = d : collect ds collect [] = []
src/Idris/ParseOps.hs view
@@ -37,7 +37,8 @@ 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 -> PEq fc Placeholder Placeholder x y) AssocLeft],+ [nofixityoperator]] where flatten :: PTerm -> PTerm -- flatten application flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))@@ -79,6 +80,13 @@ indentPropHolds gtProp fc <- getFC return (\x y -> PApp fc (PRef fc n) [pexp x, pexp y])) AssocNone++-- | Operator without fixity (throws an error)+nofixityoperator :: Operator IdrisParser PTerm+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
src/Idris/Parser.hs view
@@ -9,7 +9,7 @@ import Prelude hiding (pi) import Text.Trifecta.Delta-import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)+import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace, Err) import Text.Parser.LookAhead import Text.Parser.Expression import qualified Text.Parser.Token as Tok@@ -50,7 +50,6 @@ import Control.Applicative hiding (Const) import Control.Monad-import Control.Monad.Except (throwError, catchError) import Control.Monad.State.Strict import Data.Function@@ -88,7 +87,7 @@ {- | Parses module definition @- ModuleHeader ::= 'module' Identifier_t ';'?;+ ModuleHeader ::= DocComment_t? 'module' Identifier_t ';'?; @ -} moduleHeader :: IdrisParser (Maybe (Docstring ()), [String])@@ -221,10 +220,10 @@ -} syntaxDecl :: SyntaxInfo -> IdrisParser PDecl syntaxDecl syn = do s <- syntaxRule syn- i <- get + i <- get put (i `addSyntax` s) fc <- getFC- return (PSyntax fc s) + return (PSyntax fc s) -- | Extend an 'IState' with a new syntax extension. See also 'addReplSyntax'. addSyntax :: IState -> Syntax -> IState@@ -292,6 +291,10 @@ mkSimple' (Expr e : Expr e1 : es) = SimpleExpr e : SimpleExpr e1 : mkSimple es+ -- Can't parse a full expression followed by operator like characters due to ambiguity+ mkSimple' (Expr e : Symbol s : es)+ | takeWhile (`elem` opChars) ts /= "" && ts `notElem` invalidOperators = SimpleExpr e : Symbol s : mkSimple' es+ where ts = dropWhile isSpace . dropWhileEnd isSpace $ s mkSimple' (e : es) = e : mkSimple' es mkSimple' [] = [] @@ -345,13 +348,9 @@ fnDecl' syn = checkFixity $ do (doc, argDocs, fc, opts', n, acc) <- try (do pushIndent- (doc, argDocs) <- option noDocs docComment+ (doc, argDocs) <- docstring syn ist <- get- let doc' = annotCode (tryFullExpr syn ist) doc- argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)- | (n, d) <- argDocs ]-- initOpts = if default_total ist+ let initOpts = if default_total ist then [TotalFn] else [] opts <- fnOpts initOpts@@ -361,7 +360,7 @@ let n = expandNS syn n_in fc <- getFC lchar ':'- return (doc', argDocs', fc, opts', n, acc))+ return (doc, argDocs, fc, opts', n, acc)) ty <- typeExpr (allowImp syn) terminator addAcc n acc@@ -425,6 +424,8 @@ fnOpts (CExport c : opts) <|> do try (lchar '%' *> reserved "no_implicit"); fnOpts (NoImplicit : opts)+ <|> do try (lchar '%' *> reserved "inline");+ fnOpts (Inlinable : opts) <|> do try (lchar '%' *> reserved "assert_total"); fnOpts (AssertTotal : opts) <|> do try (lchar '%' *> reserved "error_handler");@@ -454,12 +455,10 @@ @ -} postulate :: SyntaxInfo -> IdrisParser PDecl-postulate syn = do doc <- try $ do (doc, _) <- option noDocs docComment- ist <- get- let doc' = annotCode (tryFullExpr syn ist) doc+postulate syn = do doc <- try $ do (doc, _) <- docstring syn pushIndent reserved "postulate"- return doc'+ return doc ist <- get let initOpts = if default_total ist then [TotalFn]@@ -582,7 +581,7 @@ classBlock :: SyntaxInfo -> IdrisParser [PDecl] classBlock syn = do reserved "where" openBlock- ds <- many ((notEndBlock >> instance_ syn) <|> fnDecl syn)+ ds <- many (notEndBlock >> instance_ syn <|> fnDecl syn) closeBlock return (concat ds) <?> "class block"@@ -603,22 +602,25 @@ @ -} class_ :: SyntaxInfo -> IdrisParser [PDecl]-class_ syn = do (doc, argDocs, acc) <- try (do- (doc, argDocs) <- option noDocs docComment- ist <- get- let doc' = annotCode (tryFullExpr syn ist) doc- argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)- | (n, d) <- argDocs ]- acc <- optional accessibility- return (doc', argDocs', acc))- reserved "class"; fc <- getFC; cons <- constraintList syn; n_in <- fnName+class_ syn = do (doc, argDocs, acc)+ <- try (do (doc, argDocs) <- docstring syn+ acc <- optional accessibility+ reserved "class"+ return (doc, argDocs, acc))+ fc <- getFC+ cons <- constraintList syn+ n_in <- fnName let n = expandNS syn n_in cs <- many carg+ fds <- option (map fst cs) fundeps ds <- option [] (classBlock syn) accData acc n (concatMap declared ds)- return [PClass doc syn fc cons n cs argDocs ds]+ return [PClass doc syn fc cons n cs argDocs fds ds] <?> "type-class declaration" where+ fundeps :: IdrisParser [Name]+ fundeps = do lchar '|'; sepBy name (lchar ',')+ carg :: IdrisParser (Name, PTerm) carg = do lchar '('; i <- name; lchar ':'; ty <- expr syn; lchar ')' return (i, ty)@@ -629,7 +631,7 @@ @ Instance ::=- 'instance' InstanceName? ConstraintList? Name SimpleExpr* InstanceBlock?+ DocComment_t? 'instance' InstanceName? ConstraintList? Name SimpleExpr* InstanceBlock? ; @ @@ -638,7 +640,9 @@ @ -} instance_ :: SyntaxInfo -> IdrisParser [PDecl]-instance_ syn = do reserved "instance"; fc <- getFC+instance_ syn = do (doc, argDocs)+ <- try (docstring syn <* reserved "instance")+ fc <- getFC en <- optional instanceName cs <- constraintList syn cn <- fnName@@ -646,7 +650,7 @@ let sc = PApp fc (PRef fc cn) (map pexp args) let t = bindList (PPi constraint) cs sc ds <- option [] (instanceBlock syn)- return [PInstance syn fc cs cn args t en ds]+ return [PInstance doc argDocs syn fc cs cn args t en ds] <?> "instance declaration" where instanceName :: IdrisParser Name instanceName = do lchar '['; n_in <- fnName; lchar ']'@@ -655,6 +659,18 @@ <?> "instance name" +-- | Parse a docstring+docstring :: SyntaxInfo+ -> IdrisParser (Docstring (Either Err PTerm),+ [(Name,Docstring (Either Err PTerm))])+docstring syn = do (doc, argDocs) <- option noDocs docComment+ ist <- get+ let doc' = annotCode (tryFullExpr syn ist) doc+ argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)+ | (n, d) <- argDocs ]+ return (doc', argDocs')++ {- | Parses a using declaration list @@@ -825,11 +841,12 @@ popIndent reserved "with" wval <- simpleExpr syn+ pn <- optProof openBlock ds <- some $ fnDecl syn let withs = concat ds closeBlock- return $ PWithR fc wargs wval withs)+ return $ PWithR fc wargs wval pn withs) <|> do ty <- try (do pushIndent ty <- simpleExpr syn symbol "<=="@@ -877,6 +894,7 @@ popIndent reserved "with" wval <- bracketed syn+ pn <- optProof openBlock ds <- some $ fnDecl syn closeBlock@@ -884,7 +902,7 @@ let capp = PApp fc (PRef fc n) [pexp l, pexp r] let withs = map (fillLHSD n capp wargs) $ concat ds put (ist { lastParse = Just n })- return $ PWith fc n capp wargs wval withs)+ return $ PWith fc n capp wargs wval pn withs) <|> do pushIndent n_in <- fnName; let n = expandNS syn n_in cargs <- many (constraintArg syn)@@ -910,19 +928,24 @@ ist <- get put (ist { lastParse = Just n }) wval <- bracketed syn+ pn <- optProof openBlock ds <- some $ fnDecl syn let withs = map (fillLHSD n capp wargs) $ concat ds closeBlock popIndent- return $ PWith fc n capp wargs wval withs)+ return $ PWith fc n capp wargs wval pn withs) <?> "function clause" where+ optProof = option Nothing (do reserved "proof"+ n <- fnName+ return (Just n))+ fillLHS :: Name -> PTerm -> [PTerm] -> PClause -> PClause fillLHS n capp owargs (PClauseR fc wargs v ws) = PClause fc n capp (owargs ++ wargs) v ws- fillLHS n capp owargs (PWithR fc wargs v ws)- = PWith fc n capp (owargs ++ wargs) v+ fillLHS n capp owargs (PWithR fc wargs v pn ws)+ = PWith fc n capp (owargs ++ wargs) v pn (map (fillLHSD n capp (owargs ++ wargs)) ws) fillLHS _ _ _ c = c @@ -1056,6 +1079,12 @@ mapM_ (addIBC . IBCFunctionErrorHandler fn' arg) ns')] <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt; return [PDirective (addLangExt ext)]+ <|> do fc <- getFC+ try (lchar '%' *> reserved "used")+ fn <- fnName+ arg <- iName []+ return [PDirective (addUsedName fc fn arg)]+ <?> "directive" where disambiguate :: Name -> Idris Name disambiguate n = do i <- getIState@@ -1083,25 +1112,30 @@ {- | Parses a type provider @-Provider ::= '%' 'provide' Provider_What? '(' FnName TypeSig ')' 'with' Expr;+Provider ::= DocComment_t? '%' 'provide' Provider_What? '(' FnName TypeSig ')' 'with' Expr; ProviderWhat ::= 'proof' | 'term' | 'type' | 'postulate' @ -} provider :: SyntaxInfo -> IdrisParser [PDecl]-provider syn = do try (lchar '%' *> reserved "provide");- provideTerm <|> providePostulate+provider syn = do doc <- try (do (doc, _) <- docstring syn+ lchar '%'+ reserved "provide"+ return doc)+ provideTerm doc <|> providePostulate doc <?> "type provider"- where provideTerm = do lchar '('; n <- fnName; lchar ':'; t <- typeExpr syn; lchar ')'- fc <- getFC- reserved "with"- e <- expr syn <?> "provider expression"- return [PProvider syn fc (ProvTerm t e) n]- providePostulate = do reserved "postulate"- n <- fnName- fc <- getFC- reserved "with"- e <- expr syn <?> "provider expression"- return [PProvider syn fc (ProvPostulate e) n]+ where provideTerm doc =+ do lchar '('; n <- 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+ fc <- getFC+ reserved "with"+ e <- expr syn <?> "provider expression"+ return [PProvider doc syn fc (ProvPostulate e) n] {- | Parses a transform @@ -1185,7 +1219,7 @@ i <- getIState case idris_outputmode i of RawOutput h -> iputStrLn (show $ fixColour (idris_colourRepl i) doc)- IdeSlave n h -> iWarn fc (P.text msg)+ IdeMode n h -> iWarn fc (P.text msg) putIState (i { errSpan = Just fc }) return [] Success (x, i) -> do putIState i@@ -1203,14 +1237,14 @@ {- | Load idris module and show error if something wrong happens -} loadModule :: FilePath -> Idris (Maybe String) loadModule f- = idrisCatch (fmap Just (loadModule' f))+ = idrisCatch (loadModule' f) (\e -> do setErrSpan (getErrSpan e) ist <- getIState iWarn (getErrSpan e) $ pprintErr ist e return Nothing) {- | Load idris module -}-loadModule' :: FilePath -> Idris String+loadModule' :: FilePath -> Idris (Maybe String) loadModule' f = do i <- getIState let file = takeWhile (/= ' ') f@@ -1218,7 +1252,8 @@ ids <- allImportDirs fp <- findImport ids ibcsd file if file `elem` imported i- then iLOG $ "Already read " ++ file+ then do iLOG $ "Already read " ++ file+ return Nothing else do putIState (i { imported = file : imported i }) case fp of IDR fn -> loadSource False fn Nothing@@ -1229,9 +1264,7 @@ case src of IDR sfn -> loadSource False sfn Nothing LIDR sfn -> loadSource True sfn Nothing)- let (dir, fh) = splitFileName file- return (dropExtension fh)-+ return $ Just file {- | Load idris code from file -} loadFromIFile :: Bool -> IFileType -> Maybe Int -> Idris ()@@ -1270,7 +1303,7 @@ let imports = map (\n -> (True, n, Just n, emptyFC)) ai ++ imports_in ids <- allImportDirs ibcsd <- valIBCSubDir i- mapM_ (\(re, f) -> + mapM_ (\(re, f) -> do fp <- findImport ids ibcsd f case fp of LIDR fn -> ifail $ "No ibc for " ++ f@@ -1298,8 +1331,24 @@ mapM_ (addIBC . IBCImport) [(reexport, realName) | (reexport, realName, alias, fc) <- imports] let syntax = defaultSyntax{ syn_namespace = reverse mname, maxline = toline }+ ist <- getIState+ -- Save the span from parsing the module header, because+ -- an empty program parse might obliterate it.+ let oldSpan = idris_parsedSpan ist ds' <- parseProg syntax f file pos + case (ds', oldSpan) of+ ([], Just fc) ->+ -- If no program elements were parsed, we dind't+ -- get a loaded region in the IBC file. That+ -- means we need to add it back.+ do ist <- getIState+ putIState ist { idris_parsedSpan = oldSpan+ , ibc_write = IBCParsedRegion fc :+ ibc_write ist+ }+ _ -> return ()+ -- Parsing done, now process declarations let ds = namespaces mname ds'@@ -1370,9 +1419,9 @@ toMutual (PNamespace x ds) = PNamespace x (map toMutual ds) toMutual x = let r = PMutual (fileFC "single mutual") [x] in case x of- PClauses _ _ _ _ -> r- PClass _ _ _ _ _ _ _ _ -> r- PInstance _ _ _ _ _ _ _ _ -> r+ PClauses{} -> r+ PClass{} -> r+ PInstance{} -> r _ -> x addModDoc :: SyntaxInfo -> [String] -> Docstring () -> Idris ()
src/Idris/Primitives.hs view
@@ -166,17 +166,25 @@ (2, LStrIndex) partial, Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev) (1, LStrRev) total,- Prim (sUN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)- (1, LReadStr) iopartial,++ 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) iopartial,+ (0, LStdIn) total, Prim (sUN "prim__stdout") (ty [] PtrType) 0 (p_cantreduce)- (0, LStdOut) iopartial,+ (0, LStdOut) total, Prim (sUN "prim__stderr") (ty [] PtrType) 0 (p_cantreduce)- (0, LStdErr) iopartial,+ (0, LStdErr) total, Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce) (0, LNullPtr) total, -- Managed pointer registration
src/Idris/ProofSearch.hs view
@@ -132,12 +132,13 @@ 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 = try' (trivial elab ist)- (try' (try' (resolveByCon (d - 1)) (resolveByLocals (d - 1))- True)+ psRec True d = do compute+ try' (trivial elab ist)+ (try' (try' (resolveByCon (d - 1)) (resolveByLocals (d - 1))+ True) -- if all else fails, make a new metavariable (if fromProver - then cantSolveGoal+ then fail "cantSolveGoal" else do attack; defer [] nroot; solve) True) True getFn d Nothing = []@@ -170,7 +171,7 @@ tryLocalArg d n a tryLocalArg d n 0 = elab (PRef (fileFC "prf") n)- tryLocalArg d n i = simple_app (tryLocalArg d n (i - 1))+ tryLocalArg d n i = simple_app False (tryLocalArg d n (i - 1)) (psRec True d) "proof search local apply" -- Like type class resolution, but searching with constructors
src/Idris/Prover.hs view
@@ -20,7 +20,7 @@ import Idris.Error import Idris.DataOpts import Idris.Completion-import qualified Idris.IdeSlave as IdeSlave+import qualified Idris.IdeMode as IdeMode import Idris.Output import Idris.TypeSearch (searchByType) @@ -67,26 +67,26 @@ prove :: Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris () prove opt ctxt lit n ty = do let ps = initElaborator n ctxt ty- ideslavePutSExp "start-proof-mode" n+ idemodePutSExp "start-proof-mode" n (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, initEState) "" Nothing) Nothing iLOG $ "Adding " ++ show tm i <- getIState case idris_outputmode i of- IdeSlave _ _ -> ideslavePutSExp "end-proof-mode" (n, showProof lit n prf)+ IdeMode _ _ -> idemodePutSExp "end-proof-mode" (n, showProof lit n prf) _ -> iputStrLn $ showProof lit n prf let proofs = proof_list i putIState (i { proof_list = (n, prf) : proofs }) let tree = simpleCase False (STerm Erased) False CompileTime (fileFC "proof") [] [] [([], P Ref n ty, tm)] logLvl 3 (show tree)- (ptm, pty) <- recheckC (fileFC "proof") [] tm+ (ptm, pty) <- recheckC (fileFC "proof") id [] tm logLvl 5 ("Proof type: " ++ show pty ++ "\n" ++ "Expected type:" ++ show ty) case converts ctxt [] ty pty of OK _ -> return ()- Error e -> ierror (CantUnify False ty pty e [] 0)+ Error e -> ierror (CantUnify False (ty, Nothing) (pty, Nothing) e [] 0) ptm' <- applyOpts ptm ei <- getErasureInfo `fmap` getIState- updateContext (addCasedef n ei (CaseInfo True False) False (STerm Erased) True False+ updateContext (addCasedef n ei (CaseInfo True True False) False (STerm Erased) True False [] [] -- argtys, inaccArgs [Right (P Ref n ty, ptm)] [([], P Ref n ty, ptm)]@@ -95,8 +95,8 @@ [([], P Ref n ty, ptm')] ty) solveDeferred n case idris_outputmode i of- IdeSlave n h ->- runIO . hPutStrLn h $ IdeSlave.convSExp "return" (IdeSlave.SymbolAtom "ok", "") n+ IdeMode n h ->+ runIO . hPutStrLn h $ IdeMode.convSExp "return" (IdeMode.SymbolAtom "ok", "") n _ -> return () elabStep :: ElabState EState -> ElabD a -> Idris (a, ElabState EState)@@ -185,24 +185,24 @@ receiveInput h e = do i <- getIState let inh = if h == stdout then stdin else h- len' <- runIO $ IdeSlave.getLen inh+ len' <- runIO $ IdeMode.getLen inh len <- case len' of Left err -> ierror err Right n -> return n- l <- runIO $ IdeSlave.getNChar inh len ""- (sexp, id) <- case IdeSlave.parseMessage l of+ l <- runIO $ IdeMode.getNChar inh len ""+ (sexp, id) <- case IdeMode.parseMessage l of Left err -> ierror err Right (sexp, id) -> return (sexp, id)- putIState $ i { idris_outputmode = (IdeSlave id h) }- case IdeSlave.sexpToCommand sexp of- Just (IdeSlave.REPLCompletions prefix) ->+ putIState $ i { idris_outputmode = (IdeMode id h) }+ case IdeMode.sexpToCommand sexp of+ Just (IdeMode.REPLCompletions prefix) -> do (unused, compls) <- proverCompletion (assumptionNames e) (reverse prefix, "")- let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok", IdeSlave.toSExp (map replacement compls, reverse unused)]- ideslavePutSExp "return" good+ let good = IdeMode.SexpList [IdeMode.SymbolAtom "ok", IdeMode.toSExp (map replacement compls, reverse unused)]+ idemodePutSExp "return" good receiveInput h e- Just (IdeSlave.Interpret cmd) -> return (Just cmd)- Just (IdeSlave.TypeOf str) -> return (Just (":t " ++ str))- Just (IdeSlave.DocsFor str) -> return (Just (":doc " ++ str))+ Just (IdeMode.Interpret cmd) -> return (Just cmd)+ Just (IdeMode.TypeOf str) -> return (Just (":t " ++ str))+ Just (IdeMode.DocsFor str _) -> return (Just (":doc " ++ str)) _ -> return Nothing ploop :: Name -> Bool -> String -> [String] -> ElabState EState -> Maybe History -> Idris (Term, [String])@@ -221,7 +221,7 @@ l <- getInputLine (prompt ++ "> ") h' <- getHistory return (l, Just h')- IdeSlave _ handle ->+ IdeMode _ handle -> do isetPrompt prompt i <- receiveInput handle e return (i, h)@@ -254,7 +254,7 @@ (_, st) <- elabStep e (runTac autoSolve i (Just proverFC) fn tac) return (True, st, False, prf ++ [step], Right $ iPrintResult "")) (\err -> return (False, e, False, prf, Left err))- ideslavePutSExp "write-proof-state" (prf', length prf')+ idemodePutSExp "write-proof-state" (prf', length prf') case res of Left err -> do ist <- getIState iRenderError $ pprintErr ist err@@ -336,7 +336,7 @@ return (False, e, False, prf, Right $ iRenderResult (vsep toShow))) (\err -> do putIState ist ; ierror err)- where showDoc ist (n, d) = do doc <- getDocs n+ where showDoc ist (n, d) = do doc <- getDocs n FullDocs return $ pprintDocs ist doc docStr (Right c) = do ist <- getIState return (False, e, False, prf, Right . iRenderResult $ pprintConstDocs ist c (constDocs c))
src/Idris/Providers.hs view
@@ -10,16 +10,16 @@ -- | Wrap a type provider in the type of type providers providerTy :: FC -> PTerm -> PTerm providerTy fc tm- = PApp fc (PRef fc $ sUN "Provider") [PExp 0 [] (sMN 0 "pvarg") tm]+ = PApp fc (PRef fc $ sNS (sUN "Provider" ) ["Providers", "Prelude"]) [PExp 0 [] (sMN 0 "pvarg") tm] ioret :: Name ioret = sUN "prim_io_return" ermod :: Name-ermod = sNS (sUN "Error") ["Providers"]+ermod = sNS (sUN "Error") ["Providers", "Prelude"] prmod :: Name-prmod = sNS (sUN "Provide") ["Providers"]+prmod = sNS (sUN "Provide") ["Providers", "Prelude"] data Provided a = Provide a deriving (Show, Eq, Functor)
src/Idris/REPL.hs view
@@ -22,7 +22,7 @@ import Idris.Coverage import Idris.Docs hiding (Doc) import Idris.Completion-import qualified Idris.IdeSlave as IdeSlave+import qualified Idris.IdeMode as IdeMode import Idris.Chaser import Idris.Imports import Idris.Colours hiding (colourise)@@ -54,9 +54,11 @@ import IRTS.Compiler import IRTS.CodegenCommon+import IRTS.Exports import IRTS.System import Control.Category+import qualified Control.Exception as X import Prelude hiding ((.), id) import Data.List.Split (splitOn) import Data.List (groupBy)@@ -164,7 +166,7 @@ cmd <- hGetLine h let isth = case idris_outputmode ist of RawOutput _ -> ist {idris_outputmode = RawOutput h}- IdeSlave n _ -> ist {idris_outputmode = IdeSlave n h}+ IdeMode n _ -> ist {idris_outputmode = IdeMode n h} (ist', fn) <- processNetCmd orig isth h fn cmd hClose h loop fn ist' sock@@ -203,78 +205,90 @@ do ist <- getIState putIState $ case idris_outputmode ist of RawOutput _ -> ist {idris_outputmode = RawOutput h}- IdeSlave n _ -> ist {idris_outputmode = IdeSlave n h}+ IdeMode n _ -> ist {idris_outputmode = IdeMode n h} -- | Run a command on the server on localhost runClient :: PortID -> String -> IO () runClient port str = withSocketsDo $ do- h <- connectTo "localhost" port+ res <- X.try (connectTo "localhost" port)+ case res of+ Right h -> do hSetEncoding h utf8 hPutStrLn h str resp <- hGetResp "" h putStr resp hClose h++ Left err -> do+ connectionError err+ exitWith (ExitFailure 1)+ where hGetResp acc h = do eof <- hIsEOF h if eof then return acc else do l <- hGetLine h hGetResp (acc ++ l ++ "\n") h -initIdeslaveSocket :: IO Handle-initIdeslaveSocket = do+ connectionError :: X.SomeException -> IO ()+ connectionError _ =+ putStrLn "Unable to connect to a running Idris repl"+++initIdemodeSocket :: IO Handle+initIdemodeSocket = do (sock, port) <- listenOnLocalhostAnyPort putStrLn $ show port (h, _, _) <- accept sock hSetEncoding h utf8 return h --- | Run the IdeSlave-ideslaveStart :: Bool -> IState -> [FilePath] -> Idris ()-ideslaveStart s orig mods- = do h <- runIO $ if s then initIdeslaveSocket else return stdout- setIdeSlave True h+-- | Run the IdeMode+idemodeStart :: Bool -> IState -> [FilePath] -> Idris ()+idemodeStart s orig mods+ = do h <- runIO $ if s then initIdemodeSocket else return stdout+ setIdeMode True h i <- getIState case idris_outputmode i of- IdeSlave n h ->- do runIO $ hPutStrLn h $ IdeSlave.convSExp "protocol-version" IdeSlave.ideSlaveEpoch n+ IdeMode n h ->+ do runIO $ hPutStrLn h $ IdeMode.convSExp "protocol-version" IdeMode.ideModeEpoch n case mods of- a:_ -> runIdeSlaveCommand h n i "" [] (IdeSlave.LoadFile a Nothing)+ a:_ -> runIdeModeCommand h n i "" [] (IdeMode.LoadFile a Nothing) _ -> return ()- ideslave h orig mods+ idemode h orig mods -ideslave :: Handle -> IState -> [FilePath] -> Idris ()-ideslave h orig mods+idemode :: Handle -> IState -> [FilePath] -> Idris ()+idemode h orig mods = do idrisCatch (do let inh = if h == stdout then stdin else h- len' <- runIO $ IdeSlave.getLen inh+ len' <- runIO $ IdeMode.getLen inh len <- case len' of Left err -> ierror err Right n -> return n- l <- runIO $ IdeSlave.getNChar inh len ""- (sexp, id) <- case IdeSlave.parseMessage l of+ l <- runIO $ IdeMode.getNChar inh len ""+ (sexp, id) <- case IdeMode.parseMessage l of Left err -> ierror err Right (sexp, id) -> return (sexp, id) i <- getIState- putIState $ i { idris_outputmode = (IdeSlave id h) }+ putIState $ i { idris_outputmode = (IdeMode id h) } idrisCatch -- to report correct id back! (do let fn = case mods of (f:_) -> f _ -> ""- case IdeSlave.sexpToCommand sexp of- Just cmd -> runIdeSlaveCommand h id orig fn mods cmd+ case IdeMode.sexpToCommand sexp of+ Just cmd -> runIdeModeCommand h id orig fn mods cmd Nothing -> iPrintError "did not understand" ) (\e -> do iPrintError $ show e)) (\e -> do iPrintError $ show e)- ideslave h orig mods+ idemode h orig mods --- | Run IDESlave commands-runIdeSlaveCommand :: Handle -- ^^ The handle for communication+-- | Run IDEMode commands+runIdeModeCommand :: Handle -- ^^ The handle for communication -> Integer -- ^^ The continuation ID for the client -> IState -- ^^ The original IState -> FilePath -- ^^ The current open file -> [FilePath] -- ^^ The currently loaded modules- -> IdeSlave.IdeSlaveCommand -- ^^ The command to process+ -> IdeMode.IdeModeCommand -- ^^ The command to process -> Idris ()-runIdeSlaveCommand h id orig fn mods (IdeSlave.Interpret cmd) =+runIdeModeCommand h id orig fn mods (IdeMode.Interpret cmd) = do c <- colourise i <- getIState case parseCmd i "(input)" cmd of@@ -284,96 +298,98 @@ (do process fn (Prove n') isetPrompt (mkPrompt mods) case idris_outputmode i of- IdeSlave n h -> -- signal completion of proof to ide+ IdeMode n h -> -- signal completion of proof to ide runIO . hPutStrLn h $- IdeSlave.convSExp "return"- (IdeSlave.SymbolAtom "ok", "")+ IdeMode.convSExp "return"+ (IdeMode.SymbolAtom "ok", "") n _ -> return ()) (\e -> do ist <- getIState isetPrompt (mkPrompt mods) case idris_outputmode i of- IdeSlave n h ->+ IdeMode n h -> runIO . hPutStrLn h $- IdeSlave.convSExp "abandon-proof" "Abandoned" n+ IdeMode.convSExp "abandon-proof" "Abandoned" n _ -> return () iRenderError $ pprintErr ist e) Success (Right cmd) -> idrisCatch- (ideslaveProcess fn cmd)+ (idemodeProcess fn cmd) (\e -> getIState >>= iRenderError . flip pprintErr e) Success (Left err) -> iPrintError err-runIdeSlaveCommand h id orig fn mods (IdeSlave.REPLCompletions str) =+runIdeModeCommand h id orig fn mods (IdeMode.REPLCompletions str) = do (unused, compls) <- replCompletion (reverse str, "")- let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok",- IdeSlave.toSExp (map replacement compls,+ let good = IdeMode.SexpList [IdeMode.SymbolAtom "ok",+ IdeMode.toSExp (map replacement compls, reverse unused)]- runIO . hPutStrLn h $ IdeSlave.convSExp "return" good id-runIdeSlaveCommand h id orig fn mods (IdeSlave.LoadFile filename toline) =+ runIO . hPutStrLn h $ IdeMode.convSExp "return" good id+runIdeModeCommand h id orig fn mods (IdeMode.LoadFile filename toline) = do i <- getIState clearErr putIState (orig { idris_options = idris_options i,- idris_outputmode = (IdeSlave id h) })+ idris_outputmode = (IdeMode id h) }) mods <- loadInputs [filename] toline isetPrompt (mkPrompt mods) -- Report either success or failure i <- getIState case (errSpan i) of- Nothing -> let msg = maybe (IdeSlave.SexpList [IdeSlave.SymbolAtom "ok",- IdeSlave.SexpList []])- (\fc -> IdeSlave.SexpList [IdeSlave.SymbolAtom "ok",- IdeSlave.toSExp fc])+ Nothing -> let msg = maybe (IdeMode.SexpList [IdeMode.SymbolAtom "ok",+ IdeMode.SexpList []])+ (\fc -> IdeMode.SexpList [IdeMode.SymbolAtom "ok",+ IdeMode.toSExp fc]) (idris_parsedSpan i)- in runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id+ in runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id Just x -> iPrintError $ "didn't load " ++ filename- ideslave h orig mods-runIdeSlaveCommand h id orig fn mods (IdeSlave.TypeOf name) =+ idemode h orig mods+runIdeModeCommand h id orig fn mods (IdeMode.TypeOf name) = case splitName name of Left err -> iPrintError err- Right n -> process "(ideslave)"- (Check (PRef (FC "(ideslave)" (0,0) (0,0)) n))-runIdeSlaveCommand h id orig fn mods (IdeSlave.DocsFor name) =+ Right n -> process "(idemode)"+ (Check (PRef (FC "(idemode)" (0,0) (0,0)) n))+runIdeModeCommand h id orig fn mods (IdeMode.DocsFor name w) = case parseConst orig name of- Success c -> process "(ideslave)" (DocStr (Right c))+ Success c -> process "(idemode)" (DocStr (Right c) (howMuch w)) Failure _ -> case splitName name of Left err -> iPrintError err- Right n -> process "(ideslave)" (DocStr (Left n))-runIdeSlaveCommand h id orig fn mods (IdeSlave.CaseSplit line name) =+ Right n -> process "(idemode)" (DocStr (Left n) (howMuch w))+ where howMuch IdeMode.Overview = OverviewDocs+ howMuch IdeMode.Full = FullDocs+runIdeModeCommand h id orig fn mods (IdeMode.CaseSplit line name) = process fn (CaseSplitAt False line (sUN name))-runIdeSlaveCommand h id orig fn mods (IdeSlave.AddClause line name) =+runIdeModeCommand h id orig fn mods (IdeMode.AddClause line name) = process fn (AddClauseFrom False line (sUN name))-runIdeSlaveCommand h id orig fn mods (IdeSlave.AddProofClause line name) =+runIdeModeCommand h id orig fn mods (IdeMode.AddProofClause line name) = process fn (AddProofClauseFrom False line (sUN name))-runIdeSlaveCommand h id orig fn mods (IdeSlave.AddMissing line name) =+runIdeModeCommand h id orig fn mods (IdeMode.AddMissing line name) = process fn (AddMissing False line (sUN name))-runIdeSlaveCommand h id orig fn mods (IdeSlave.MakeWithBlock line name) =+runIdeModeCommand h id orig fn mods (IdeMode.MakeWithBlock line name) = process fn (MakeWith False line (sUN name))-runIdeSlaveCommand h id orig fn mods (IdeSlave.ProofSearch r line name hints depth) =+runIdeModeCommand h id orig fn mods (IdeMode.ProofSearch r line name hints depth) = doProofSearch fn False r line (sUN name) (map sUN hints) depth-runIdeSlaveCommand h id orig fn mods (IdeSlave.MakeLemma line name) =+runIdeModeCommand h id orig fn mods (IdeMode.MakeLemma line name) = case splitName name of Left err -> iPrintError err Right n -> process fn (MakeLemma False line n)-runIdeSlaveCommand h id orig fn mods (IdeSlave.Apropos a) =+runIdeModeCommand h id orig fn mods (IdeMode.Apropos a) = process fn (Apropos [] a)-runIdeSlaveCommand h id orig fn mods (IdeSlave.GetOpts) =+runIdeModeCommand h id orig fn mods (IdeMode.GetOpts) = do ist <- getIState let opts = idris_options ist let impshow = opt_showimp opts let errCtxt = opt_errContext opts- let options = (IdeSlave.SymbolAtom "ok",- [(IdeSlave.SymbolAtom "show-implicits", impshow),- (IdeSlave.SymbolAtom "error-context", errCtxt)])- runIO . hPutStrLn h $ IdeSlave.convSExp "return" options id-runIdeSlaveCommand h id orig fn mods (IdeSlave.SetOpt IdeSlave.ShowImpl b) =+ let options = (IdeMode.SymbolAtom "ok",+ [(IdeMode.SymbolAtom "show-implicits", impshow),+ (IdeMode.SymbolAtom "error-context", errCtxt)])+ runIO . hPutStrLn h $ IdeMode.convSExp "return" options id+runIdeModeCommand h id orig fn mods (IdeMode.SetOpt IdeMode.ShowImpl b) = do setImpShow b- let msg = (IdeSlave.SymbolAtom "ok", b)- runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id-runIdeSlaveCommand h id orig fn mods (IdeSlave.SetOpt IdeSlave.ErrContext b) =+ let msg = (IdeMode.SymbolAtom "ok", b)+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id+runIdeModeCommand h id orig fn mods (IdeMode.SetOpt IdeMode.ErrContext b) = do setErrContext b- let msg = (IdeSlave.SymbolAtom "ok", b)- runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id-runIdeSlaveCommand h id orig fn mods (IdeSlave.Metavariables cols) =+ let msg = (IdeMode.SymbolAtom "ok", b)+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id+runIdeModeCommand h id orig fn mods (IdeMode.Metavariables cols) = do ist <- getIState let mvs = reverse $ map fst (idris_metavars ist) \\ primDefs let ppo = ppOptionIst ist@@ -390,7 +406,7 @@ render ist bnd c pc)) splitMvs runIO . hPutStrLn h $- IdeSlave.convSExp "return" (IdeSlave.SymbolAtom "ok", mvOutput) id+ IdeMode.convSExp "return" (IdeMode.SymbolAtom "ok", mvOutput) id where mapPair f g xs = zip (map (f . fst) xs) (map (g . snd) xs) mapSnd f xs = zip (map fst xs) (map (f . snd) xs) @@ -434,32 +450,32 @@ let (out, spans) = render ist bnd t pt in (show n , out, spans) -runIdeSlaveCommand h id orig fn mods (IdeSlave.WhoCalls n) =+runIdeModeCommand h id orig fn mods (IdeMode.WhoCalls n) = case splitName n of Left err -> iPrintError err Right n -> do calls <- whoCalls n ist <- getIState- let msg = (IdeSlave.SymbolAtom "ok",+ let msg = (IdeMode.SymbolAtom "ok", map (\ (n,ns) -> (pn ist n, map (pn ist) ns)) calls)- runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id where pn ist = displaySpans . renderPretty 0.9 1000 . fmap (fancifyAnnots ist) . prettyName True True []-runIdeSlaveCommand h id orig fn mods (IdeSlave.CallsWho n) =+runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) = case splitName n of Left err -> iPrintError err Right n -> do calls <- callsWho n ist <- getIState- let msg = (IdeSlave.SymbolAtom "ok",+ let msg = (IdeMode.SymbolAtom "ok", map (\ (n,ns) -> (pn ist n, map (pn ist) ns)) calls)- runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id where pn ist = displaySpans . renderPretty 0.9 1000 . fmap (fancifyAnnots ist) . prettyName True True [] -runIdeSlaveCommand h id orig fn modes (IdeSlave.TermNormalise bnd tm) =+runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) = do ctxt <- getContext ist <- getIState let tm' = force (normaliseAll ctxt [] tm)@@ -469,46 +485,63 @@ [] (idris_infixes ist) (delab ist tm'))- msg = (IdeSlave.SymbolAtom "ok",+ msg = (IdeMode.SymbolAtom "ok", displaySpans . renderPretty 0.9 80 . fmap (fancifyAnnots ist) $ ptm)- runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id-runIdeSlaveCommand h id orig fn modes (IdeSlave.TermShowImplicits bnd tm) =- ideSlaveForceTermImplicits h id bnd True tm-runIdeSlaveCommand h id orig fn modes (IdeSlave.TermNoImplicits bnd tm) =- ideSlaveForceTermImplicits h id bnd False tm-runIdeSlaveCommand h id orig fn mods (IdeSlave.PrintDef name) =+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id+runIdeModeCommand h id orig fn modes (IdeMode.TermShowImplicits bnd tm) =+ ideModeForceTermImplicits h id bnd True tm+runIdeModeCommand h id orig fn modes (IdeMode.TermNoImplicits bnd tm) =+ ideModeForceTermImplicits h id bnd False tm+runIdeModeCommand h id orig fn modes (IdeMode.TermElab bnd tm) =+ do ist <- getIState+ let ptm = annotate (AnnTerm bnd tm)+ (pprintTT (map fst bnd) tm)+ msg = (IdeMode.SymbolAtom "ok",+ displaySpans .+ renderPretty 0.9 70 .+ fmap (fancifyAnnots ist) $ ptm)+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id+runIdeModeCommand h id orig fn mods (IdeMode.PrintDef name) = case splitName name of Left err -> iPrintError err- Right n -> process "(ideslave)" (PrintDef n)-runIdeSlaveCommand h id orig fn modes (IdeSlave.ErrString e) =+ Right n -> process "(idemode)" (PrintDef n)+runIdeModeCommand h id orig fn modes (IdeMode.ErrString e) = do ist <- getIState let out = displayS . renderPretty 1.0 60 $ pprintErr ist e- msg = (IdeSlave.SymbolAtom "ok", IdeSlave.StringAtom $ out "")- runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id-runIdeSlaveCommand h id orig fn modes (IdeSlave.ErrPPrint e) =+ msg = (IdeMode.SymbolAtom "ok", IdeMode.StringAtom $ out "")+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id+runIdeModeCommand h id orig fn modes (IdeMode.ErrPPrint e) = do ist <- getIState let (out, spans) = displaySpans . renderPretty 0.9 80 . fmap (fancifyAnnots ist) $ pprintErr ist e- msg = (IdeSlave.SymbolAtom "ok", out, spans)- runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id+ msg = (IdeMode.SymbolAtom "ok", out, spans)+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id+runIdeModeCommand h id orig fn modes IdeMode.GetIdrisVersion =+ let idrisVersion = (versionBranch version,+ if not (null gitHash)+ then [gitHash]+ else [])+ msg = (IdeMode.SymbolAtom "ok", idrisVersion)+ in runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id --- | Show a term for IDESlave with the specified implicitness-ideSlaveForceTermImplicits :: Handle -> Integer -> [(Name, Bool)] -> Bool -> Term -> Idris ()-ideSlaveForceTermImplicits h id bnd impl tm =++-- | Show a term for IDEMode with the specified implicitness+ideModeForceTermImplicits :: Handle -> Integer -> [(Name, Bool)] -> Bool -> Term -> Idris ()+ideModeForceTermImplicits h id bnd impl tm = do ist <- getIState let expl = annotate (AnnTerm bnd tm) (pprintPTerm ((ppOptionIst ist) { ppopt_impl = impl }) bnd [] (idris_infixes ist) (delab ist tm))- msg = (IdeSlave.SymbolAtom "ok",+ msg = (IdeMode.SymbolAtom "ok", displaySpans . renderPretty 0.9 80 . fmap (fancifyAnnots ist) $ expl)- runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id splitName :: String -> Either String Name splitName s = case reverse $ splitOn "." s of@@ -519,75 +552,77 @@ unparen ('(':x:xs) | last xs == ')' = init (x:xs) unparen str = str -ideslaveProcess :: FilePath -> Command -> Idris ()-ideslaveProcess fn Warranty = process fn Warranty-ideslaveProcess fn Help = process fn Help-ideslaveProcess fn (ChangeDirectory f) = do process fn (ChangeDirectory f)- iPrintResult "changed directory to"-ideslaveProcess fn (Eval t) = process fn (Eval t)-ideslaveProcess fn (NewDefn decls) = do process fn (NewDefn decls)- iPrintResult "defined"-ideslaveProcess fn (Undefine n) = process fn (Undefine n)-ideslaveProcess fn (ExecVal t) = process fn (ExecVal t)-ideslaveProcess fn (Check (PRef x n)) = process fn (Check (PRef x n))-ideslaveProcess fn (Check t) = process fn (Check t)-ideslaveProcess fn (DocStr n) = process fn (DocStr n)-ideslaveProcess fn Universes = process fn Universes-ideslaveProcess fn (Defn n) = do process fn (Defn n)- iPrintResult ""-ideslaveProcess fn (TotCheck n) = process fn (TotCheck n)-ideslaveProcess fn (DebugInfo n) = do process fn (DebugInfo n)- iPrintResult ""-ideslaveProcess fn (Search ps t) = process fn (Search ps t)-ideslaveProcess fn (Spec t) = process fn (Spec t)+idemodeProcess :: FilePath -> Command -> Idris ()+idemodeProcess fn Warranty = process fn Warranty+idemodeProcess fn Help = process fn Help+idemodeProcess fn (ChangeDirectory f) = do process fn (ChangeDirectory f)+ iPrintResult "changed directory to"+idemodeProcess fn (ModImport f) = process fn (ModImport f)+idemodeProcess fn (Eval t) = process fn (Eval t)+idemodeProcess fn (NewDefn decls) = do process fn (NewDefn decls)+ iPrintResult "defined"+idemodeProcess fn (Undefine n) = process fn (Undefine n)+idemodeProcess fn (ExecVal t) = process fn (ExecVal t)+idemodeProcess fn (Check (PRef x n)) = process fn (Check (PRef x n))+idemodeProcess fn (Check t) = process fn (Check t)+idemodeProcess fn (Core t) = process fn (Core t)+idemodeProcess fn (DocStr n w) = process fn (DocStr n w)+idemodeProcess fn Universes = process fn Universes+idemodeProcess fn (Defn n) = do process fn (Defn n)+ iPrintResult ""+idemodeProcess fn (TotCheck n) = process fn (TotCheck n)+idemodeProcess fn (DebugInfo n) = do process fn (DebugInfo n)+ iPrintResult ""+idemodeProcess fn (Search ps t) = process fn (Search ps t)+idemodeProcess fn (Spec t) = process fn (Spec t) -- RmProof and AddProof not supported!-ideslaveProcess fn (ShowProof n') = process fn (ShowProof n')-ideslaveProcess fn (HNF t) = process fn (HNF t)---ideslaveProcess fn TTShell = process fn TTShell -- need some prove mode!-ideslaveProcess fn (TestInline t) = process fn (TestInline t)+idemodeProcess fn (ShowProof n') = process fn (ShowProof n')+idemodeProcess fn (HNF t) = process fn (HNF t)+--idemodeProcess fn TTShell = process fn TTShell -- need some prove mode!+idemodeProcess fn (TestInline t) = process fn (TestInline t) -ideslaveProcess fn Execute = do process fn Execute- iPrintResult ""-ideslaveProcess fn (Compile codegen f) = do process fn (Compile codegen f)- iPrintResult ""-ideslaveProcess fn (LogLvl i) = do process fn (LogLvl i)+idemodeProcess fn Execute = do process fn Execute+ iPrintResult ""+idemodeProcess fn (Compile codegen f) = do process fn (Compile codegen f)+ iPrintResult ""+idemodeProcess fn (LogLvl i) = do process fn (LogLvl i)+ iPrintResult ""+idemodeProcess fn (Pattelab t) = process fn (Pattelab t)+idemodeProcess fn (Missing n) = process fn (Missing n)+idemodeProcess fn (DynamicLink l) = do process fn (DynamicLink l)+ iPrintResult ""+idemodeProcess fn ListDynamic = do process fn ListDynamic iPrintResult ""-ideslaveProcess fn (Pattelab t) = process fn (Pattelab t)-ideslaveProcess fn (Missing n) = process fn (Missing n)-ideslaveProcess fn (DynamicLink l) = do process fn (DynamicLink l)- iPrintResult ""-ideslaveProcess fn ListDynamic = do process fn ListDynamic- iPrintResult ""-ideslaveProcess fn Metavars = process fn Metavars-ideslaveProcess fn (SetOpt ErrContext) = do process fn (SetOpt ErrContext)- iPrintResult ""-ideslaveProcess fn (UnsetOpt ErrContext) = do process fn (UnsetOpt ErrContext)- iPrintResult ""-ideslaveProcess fn (SetOpt ShowImpl) = do process fn (SetOpt ShowImpl)- iPrintResult ""-ideslaveProcess fn (UnsetOpt ShowImpl) = do process fn (UnsetOpt ShowImpl)- iPrintResult ""-ideslaveProcess fn (SetOpt ShowOrigErr) = do process fn (SetOpt ShowOrigErr)+idemodeProcess fn Metavars = process fn Metavars+idemodeProcess fn (SetOpt ErrContext) = do process fn (SetOpt ErrContext)+ iPrintResult ""+idemodeProcess fn (UnsetOpt ErrContext) = do process fn (UnsetOpt ErrContext) iPrintResult ""-ideslaveProcess fn (UnsetOpt ShowOrigErr) = do process fn (UnsetOpt ShowOrigErr)- iPrintResult ""-ideslaveProcess fn (SetOpt x) = process fn (SetOpt x)-ideslaveProcess fn (UnsetOpt x) = process fn (UnsetOpt x)-ideslaveProcess fn (CaseSplitAt False pos str) = process fn (CaseSplitAt False pos str)-ideslaveProcess fn (AddProofClauseFrom False pos str) = process fn (AddProofClauseFrom False pos str)-ideslaveProcess fn (AddClauseFrom False pos str) = process fn (AddClauseFrom False pos str)-ideslaveProcess fn (AddMissing False pos str) = process fn (AddMissing False pos str)-ideslaveProcess fn (MakeWith False pos str) = process fn (MakeWith False pos str)-ideslaveProcess fn (DoProofSearch False r pos str xs) = process fn (DoProofSearch False r pos str xs)-ideslaveProcess fn (SetConsoleWidth w) = do process fn (SetConsoleWidth w)+idemodeProcess fn (SetOpt ShowImpl) = do process fn (SetOpt ShowImpl)+ iPrintResult ""+idemodeProcess fn (UnsetOpt ShowImpl) = do process fn (UnsetOpt ShowImpl)+ iPrintResult ""+idemodeProcess fn (SetOpt ShowOrigErr) = do process fn (SetOpt ShowOrigErr) iPrintResult ""-ideslaveProcess fn (Apropos pkg a) = do process fn (Apropos pkg a)- iPrintResult ""-ideslaveProcess fn (WhoCalls n) = process fn (WhoCalls n)-ideslaveProcess fn (CallsWho n) = process fn (CallsWho n)-ideslaveProcess fn (PrintDef n) = process fn (PrintDef n)-ideslaveProcess fn (PPrint fmt n tm) = process fn (PPrint fmt n tm)-ideslaveProcess fn _ = iPrintError "command not recognized or not supported"+idemodeProcess fn (UnsetOpt ShowOrigErr) = do process fn (UnsetOpt ShowOrigErr)+ iPrintResult ""+idemodeProcess fn (SetOpt x) = process fn (SetOpt x)+idemodeProcess fn (UnsetOpt x) = process fn (UnsetOpt x)+idemodeProcess fn (CaseSplitAt False pos str) = process fn (CaseSplitAt False pos str)+idemodeProcess fn (AddProofClauseFrom False pos str) = process fn (AddProofClauseFrom False pos str)+idemodeProcess fn (AddClauseFrom False pos str) = process fn (AddClauseFrom False pos str)+idemodeProcess fn (AddMissing False pos str) = process fn (AddMissing False pos str)+idemodeProcess fn (MakeWith False pos str) = process fn (MakeWith False pos str)+idemodeProcess fn (DoProofSearch False r pos str xs) = process fn (DoProofSearch False r pos str xs)+idemodeProcess fn (SetConsoleWidth w) = do process fn (SetConsoleWidth w)+ iPrintResult ""+idemodeProcess fn (Apropos pkg a) = do process fn (Apropos pkg a)+ iPrintResult ""+idemodeProcess fn (WhoCalls n) = process fn (WhoCalls n)+idemodeProcess fn (CallsWho n) = process fn (CallsWho n)+idemodeProcess fn (PrintDef n) = process fn (PrintDef n)+idemodeProcess fn (PPrint fmt n tm) = process fn (PPrint fmt n tm)+idemodeProcess fn _ = iPrintError "command not recognized or not supported" -- | The prompt consists of the currently loaded modules, or "Idris" if there are none@@ -616,6 +651,7 @@ Success (Right Reload) -> do putIState $ orig { idris_options = idris_options i , idris_colourTheme = idris_colourTheme i+ , imported = imported i } clearErr mods <- loadInputs inputs Nothing@@ -708,6 +744,10 @@ process fn (ChangeDirectory f) = do runIO $ setCurrentDirectory f return ()+process fn (ModImport f) = do fmod <- loadModule f+ case fmod of+ Just pr -> isetPrompt pr+ Nothing -> iPrintError $ "Can't find import " ++ f process fn (Eval t) = withErrorReflection $ do logLvl 5 $ show t getIState >>= flip warnDisamb t@@ -733,11 +773,11 @@ 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 decls) = Just name+ getName (PClass doc syn fc constraints name 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 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 elabDecl EAll recinfo tyDecl@@ -766,9 +806,9 @@ getClauses _ = [] getRHS :: PClause -> PTerm getRHS (PClause fc name whole with rhs whereBlock) = rhs- getRHS (PWith fc name whole with rhs whereBlock) = rhs+ getRHS (PWith fc name whole with rhs pn whereBlock) = rhs getRHS (PClauseR fc with rhs whereBlock) = rhs- getRHS (PWithR fc with rhs whereBlock) = rhs+ getRHS (PWithR fc with rhs pn whereBlock) = rhs setReplDefined :: Maybe Name -> Idris () setReplDefined Nothing = return () setReplDefined (Just n) = do@@ -781,8 +821,8 @@ fixClauses :: PDecl' t -> PDecl' t fixClauses (PClauses fc opts _ css@(clause:cs)) = PClauses fc opts (getClauseName clause) css- fixClauses (PInstance syn fc constraints cls parms ty instName decls) =- PInstance syn fc constraints cls parms ty instName (map fixClauses decls)+ 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 decl = decl process fn (Undefine names) = undefine names@@ -794,7 +834,7 @@ -- Keep track of which names you've removed so you can -- print them out to the user afterward undefine names = undefine' names []- undefine' [] list = do iRenderOutput $ printUndefinedNames list+ undefine' [] list = do iRenderResult $ printUndefinedNames list return () undefine' (n:names) already = do allDefined <- idris_repl_defs `fmap` get@@ -878,21 +918,27 @@ _ -> iPrintTermWithType (pprintDelab ist tm) (pprintDelab ist ty) -process fn (DocStr (Left n))+process fn (Core t)+ = do (tm, ty) <- elabVal recinfo ERHS t+ iPrintTermWithType (pprintTT [] tm) (pprintTT [] ty)++process fn (DocStr (Left n) w) = do ist <- getIState let docs = lookupCtxtName n (idris_docstrings ist) ++- map (\(n,d)-> (n, (d,[]))) (lookupCtxtName (modDocN n) (idris_moduledocs ist))+ map (\(n,d)-> (n, (d, [])))+ (lookupCtxtName (modDocN n) (idris_moduledocs ist)) case docs of [] -> iPrintError $ "No documentation for " ++ show n ns -> do toShow <- mapM (showDoc ist) ns iRenderResult (vsep toShow)- where showDoc ist (n, d) = do doc <- getDocs n+ where showDoc ist (n, d) = do doc <- getDocs n w return $ pprintDocs ist doc+ modDocN (NS (UN n) ns) = NS modDocName (n:ns) modDocN (UN n) = NS modDocName [n] modDocN _ = sMN 1 "NotFoundForSure" -process fn (DocStr (Right c))+process fn (DocStr (Right c) _) -- constants only have overviews = do ist <- getIState iRenderResult $ pprintConstDocs ist c (constDocs c) @@ -937,7 +983,7 @@ = do (ltm, _) <- elabVal recinfo ERHS l (rtm, _) <- elabVal recinfo ERHS r ctxt <- getContext- case unify ctxt [] ltm rtm [] [] [] [] of+ case unify ctxt [] (ltm, Nothing) (rtm, Nothing) [] [] [] [] of OK ans -> iputStrLn (show ans) Error e -> iputStrLn (show e) @@ -1077,21 +1123,27 @@ (tmpn, tmph) <- runIO tempfile runIO $ hClose tmph t <- codegen- ir <- compile t tmpn m+ -- gcc adds .exe when it builds windows programs+ progName <- return $ if isWindows then tmpn ++ ".exe" else tmpn+ ir <- compile t tmpn (Just m) runIO $ generate t (fst (head (idris_imported ist))) ir case idris_outputmode ist of- RawOutput h -> do runIO $ rawSystem tmpn []+ RawOutput h -> do runIO $ rawSystem progName [] return ()- IdeSlave n h -> runIO . hPutStrLn h $- IdeSlave.convSExp "run-program" tmpn n)+ IdeMode n h -> runIO . hPutStrLn h $+ IdeMode.convSExp "run-program" tmpn n) (\e -> getIState >>= iRenderError . flip pprintErr e) where fc = fileFC "main" process fn (Compile codegen f) | map toLower (takeExtension f) `elem` [".idr", ".lidr", ".idc"] = iPrintError $ "Invalid filename for compiler output \"" ++ f ++"\""- | otherwise = do (m, _) <- elabVal recinfo ERHS- (PApp fc (PRef fc (sUN "run__IO"))- [pexp $ PRef fc (sNS (sUN "main") ["Main"])])+ | otherwise = do opts <- getCmdLine+ let iface = Interface `elem` opts+ m <- if iface then return Nothing else+ do (m', _) <- elabVal recinfo ERHS+ (PApp fc (PRef fc (sUN "run__IO"))+ [pexp $ PRef fc (sNS (sUN "main") ["Main"])])+ return (Just m') ir <- compile codegen f m i <- getIState runIO $ generate codegen (fst (head (idris_imported i))) ir@@ -1168,7 +1220,7 @@ process fn (Apropos pkgs a) = do orig <- getIState- when (not (null pkgs)) $ + when (not (null pkgs)) $ iputStrLn $ "Searching packages: " ++ showSep ", " pkgs mapM_ loadPkgIndex pkgs ist <- getIState@@ -1385,9 +1437,10 @@ ist <- getIState putIState (ist { idris_tyinfodata = tidata, idris_patdefs = patdefs })+ exports <- findExports case opt getOutput opts of- [] -> performUsageAnalysis -- interactive+ [] -> performUsageAnalysis (getExpNames exports) -- interactive _ -> return [] -- batch, will be checked by the compiler return (map fst ifiles))@@ -1465,10 +1518,11 @@ idrisMain :: [Opt] -> Idris () idrisMain opts =- do let inputs = opt getFile opts+ do mapM_ setWidth (opt getConsoleWidth opts)+ let inputs = opt getFile opts let quiet = Quiet `elem` opts let nobanner = NoBanner `elem` opts- let idesl = Ideslave `elem` opts || IdeslaveSocket `elem` opts+ let idesl = Idemode `elem` opts || IdemodeSocket `elem` opts let runrepl = not (NoREPL `elem` opts) let verbose = runrepl || Verbose `elem` opts let output = opt getOutput opts@@ -1480,9 +1534,11 @@ let optimise = case opt getOptLevel opts of [] -> 2 xs -> last xs+ setOptLevel optimise let outty = case opt getOutputTy opts of- [] -> Executable+ [] -> if Interface `elem` opts then+ Object else Executable xs -> last xs let cgn = case opt getCodegen opts of [] -> Via "c"@@ -1500,7 +1556,9 @@ when (DefaultTotal `elem` opts) $ do i <- getIState putIState (i { default_total = True }) setColourise $ not quiet && last (True : opt getColour opts)- when (not runrepl) $ setWidth InfinitelyWide+++ mapM_ addLangExt (opt getLanguageExt opts) setREPL runrepl setQuiet (quiet || isJust script || not (null immediate))@@ -1593,8 +1651,8 @@ -- clearOrigPats startServer port orig mods runInputT (replSettings (Just historyFile)) $ repl orig mods efile- let idesock = IdeslaveSocket `elem` opts- when (idesl) $ ideslaveStart idesock orig inputs+ let idesock = IdemodeSocket `elem` opts+ when (idesl) $ idemodeStart idesock orig inputs ok <- noErrors when (not ok) $ runIO (exitWith (ExitFailure 1)) where@@ -1606,7 +1664,7 @@ makeOption _ = return () addPkgDir :: String -> Idris ()- addPkgDir p = do ddir <- runIO $ getDataDir+ addPkgDir p = do ddir <- runIO $ getIdrisLibDir addImportDir (ddir </> p) addIBC (IBCImportDir (ddir </> p)) @@ -1723,6 +1781,12 @@ getCodegen (UseCodegen x) = Just x getCodegen _ = Nothing ++getConsoleWidth :: Opt -> Maybe ConsoleWidth+getConsoleWidth (UseConsoleWidth x) = Just x+getConsoleWidth _ = Nothing++ getExecScript :: Opt -> Maybe String getExecScript (InterpretScript expr) = Just expr getExecScript _ = Nothing@@ -1779,7 +1843,7 @@ opt :: (Opt -> Maybe a) -> [Opt] -> [a] opt = mapMaybe -ver = showVersion version ++ gitHash+ver = showVersion version ++ "-" ++ gitHash defaultPort :: PortID defaultPort = PortNumber (fromIntegral 4294)
src/Idris/REPLParser.hs view
@@ -41,6 +41,7 @@ parserCommandsForHelp :: CommandTable parserCommandsForHelp = [ exprArgCmd ["t", "type"] Check "Check the type of an expression"+ , exprArgCmd ["core"] Core "View the core language representation of a term" , nameArgCmd ["miss", "missing"] Missing "Show missing clauses" , (["doc"], NameArg, "Show internal documentation", cmd_doc) , (["mkdoc"], NamespaceArg, "Generate IdrisDoc for namespace(s) and dependencies"@@ -258,9 +259,9 @@ let constant = do c <- P.constant eof- return $ Right (DocStr (Right c))+ return $ Right (DocStr (Right c) FullDocs) - let fnName = fnNameArg (\n -> DocStr (Left n)) name+ let fnName = fnNameArg (\n -> DocStr (Left n) FullDocs) name try constant <|> fnName
+ src/Idris/Reflection.hs view
@@ -0,0 +1,18 @@+{-|+Handy tools for doing reflection.+-}+module Idris.Reflection where++import Idris.Core.TT+import Idris.AbsSyntaxTree (PArg'(..), PArg, PTerm(Placeholder))++data RArg = RExplicit { argName :: Name, argTy :: Raw }+ | RImplicit { argName :: Name, argTy :: Raw }+ | RConstraint { argName :: Name, argTy :: Raw }++data RTyDecl = RDeclare Name [RArg] Raw++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
src/Idris/TypeSearch.hs view
@@ -46,7 +46,7 @@ mapM_ loadPkgIndex pkgs pterm' <- addUsingConstraints syn emptyFC pterm pterm'' <- implicit toplevel syn name pterm'- let pterm''' = addImpl i pterm''+ let pterm''' = addImpl [] i pterm'' ty <- elabType toplevel syn (fst noDocs) (snd noDocs) emptyFC [] name pterm' let names = searchUsing searchPred i ty let names' = take numLimit names@@ -57,7 +57,7 @@ case idris_outputmode i of RawOutput _ -> do mapM_ iRenderOutput docs iPrintResult ""- IdeSlave _ _ -> iRenderResult (vsep docs)+ IdeMode _ _ -> iRenderResult (vsep docs) putIState i -- don't actually make any changes where numLimit = 50@@ -99,6 +99,14 @@ get (CaseOp _ ty _ _ _ _) = Just ty get _ = Nothing +-- 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+ Bind name binder ty -> Bind name (fmap unLazy binder) (unLazy ty)+ App t1 t2 -> App (unLazy t1) (unLazy t2)+ Proj ty i -> Proj (unLazy ty) i+ _ -> typ -- | reverse the edges for a directed acyclic graph reverseDag :: Ord k => [((k, a), Set k)] -> [((k, a), Set k)]@@ -270,7 +278,7 @@ typeclassUnify :: Ctxt ClassInfo -> Context -> Type -> Type -> Maybe [(Name, Type)] typeclassUnify classInfo ctxt ty tyTry = do- res <- tcToMaybe $ match_unify ctxt [] ty retTy [] theHoles []+ res <- tcToMaybe $ match_unify ctxt [] (ty, Nothing) (retTy, Nothing) [] theHoles [] guard $ null (theHoles \\ map fst res) let argTys' = map (second $ foldr (.) id [ subst n t | (n, t) <- res ]) tcArgs return argTys'@@ -362,7 +370,7 @@ argNames1 = map fst dag1 makeDag :: Type -> (ArgsDAG, Classes, Type) makeDag = first3 (zipWith (\i (ty, deps) -> (ty, (i, deps))) [0..] . reverseDag) . - computeDagP (isTypeClassArg classInfo) . vToP+ computeDagP (isTypeClassArg classInfo) . vToP . unLazy first3 f (a,b,c) = (f a, b, c) -- update our state with the unification resolutions@@ -416,7 +424,9 @@ unifyQueue state [] = return state unifyQueue state ((ty1, ty2) : queue) = do --trace ("go: \n" ++ show state) True `seq` return ()- res <- tcToMaybe $ match_unify ctxt [ (n, Pi Nothing ty (TType (UVar 0))) | (n, ty) <- holes state] ty1 ty2 [] (map fst $ holes state) []+ res <- tcToMaybe $ match_unify ctxt [ (n, Pi Nothing ty (TType (UVar 0))) | (n, ty) <- holes state] + (ty1, Nothing) + (ty2, Nothing) [] (map fst $ holes state) [] (state', queueAdditions) <- resolveUnis res state guard $ scoreCriterion (score state') unifyQueue state' (queue ++ queueAdditions)
src/Pkg/PParser.hs view
@@ -16,7 +16,7 @@ import Control.Monad.State.Strict import Control.Applicative -import System.Info (os)+import Util.System type PParser = StateT PkgDesc IdrisInnerParser@@ -63,7 +63,7 @@ pClause = do reserved "executable"; lchar '='; exec <- iName [] st <- get- put (st { execout = Just (if os `elem` ["win32", "mingw32", "cygwin32"] + put (st { execout = Just (if isWindows then ((show exec) ++ ".exe") else ( show exec ) ) })
src/Pkg/Package.hs view
@@ -12,7 +12,7 @@ import Control.Monad import Control.Monad.Trans.State.Strict (execStateT)-import Control.Monad.Except (runExceptT)+import Control.Monad.Trans.Except (runExceptT) import Data.List import Data.List.Split(splitOn)
src/Util/System.hs view
@@ -1,4 +1,4 @@-module Util.System(tempfile,withTempdir,rmFile,catchIO) where+module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows) where -- System helper functions. import Control.Monad (when)@@ -9,6 +9,7 @@ ) import System.FilePath ((</>), normalise) import System.IO+import System.Info import System.IO.Error import Control.Exception as CE @@ -17,6 +18,9 @@ throwIO :: IOError -> IO a throwIO = CE.throw++isWindows :: Bool+isWindows = os `elem` ["win32", "mingw32", "cygwin32"] tempfile :: IO (FilePath, Handle) tempfile = do dir <- getTemporaryDirectory
test/Makefile view
@@ -7,14 +7,8 @@ %.test: @perl ./runtest.pl $(patsubst %.test,%,$@) -test_java:- @perl ./runtest.pl without primitives004 --codegen Java- test_js:- @perl ./runtest.pl without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 effects003 buffer001 basic011 primitives004 --codegen node--test_llvm:- @perl ./runtest.pl without primitives003 primitives004 sugar004 io003 buffer001 --codegen llvm+ @perl ./runtest.pl without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 effects003 buffer001 basic007 basic011 primitives004 ffi006 --codegen node update: /usr/bin/env perl ./runtest.pl all -u
test/basic002/test006.idr view
@@ -18,7 +18,7 @@ natToBin (S (j + j)) | odd {n = j} = True :: natToBin j main : IO ()-main = do print (natToBin 42)+main = do printLn (natToBin 42) ---------- Proofs ----------
test/basic003/test027.idr view
@@ -19,7 +19,7 @@ mprod (x :: xs) = x * mprod xs main : IO ()-main = do print $ isort [1,5,3,5,1,9,8]- print $ msum [1..10]- print $ mprod [1..10]+main = do printLn $ isort [1,5,3,5,1,9,8]+ printLn $ msum [1..10]+ printLn $ mprod [1..10]
test/basic004/test016.idr view
@@ -13,5 +13,5 @@ take n [] = [] main : IO ()-main = do print (take 10 (Main.countFrom 10))+main = do printLn (take 10 (Main.countFrom 10))
test/basic005/test019.lidr view
@@ -14,5 +14,5 @@ > | False = ifFalse x > main : IO ()-> main = print (test ((S 4) ==) 5 Oh)+> main = printLn (test ((S 4) ==) 5 Oh)
test/basic006/expected view
@@ -1,8 +1,8 @@ test020a.idr:16:18:When elaborating right hand side of foo: When elaborating an application of function Prelude.List.reverse: Can't unify- Vect n a+ Vect n a (Type of xs) with- List a+ List a (Expected type) [3, 2, 1] "Number 42"
test/basic006/run view
@@ -1,5 +1,6 @@ #!/usr/bin/env bash-idris $@ test020.idr -o test020-idris $@ test020a.idr --check --nocolor++idris --consolewidth 80 $@ test020.idr -o test020+idris --consolewidth 80 $@ test020a.idr --check --nocolor ./test020 rm -f test020 *.ibc
test/basic006/test020.idr view
@@ -21,7 +21,7 @@ test x = "Number " ++ x main : IO ()-main = do print (foo [1,2,3])- print (test 42)+main = do printLn (foo [1,2,3])+ printLn (test 42)
test/basic006/test020a.idr view
@@ -16,5 +16,5 @@ foo xs = reverse xs main : IO ()-main = print (foo [1,2,3])+main = printLn (foo [1,2,3])
test/basic007/test033.idr view
@@ -1,4 +1,4 @@ module Main main : IO ()-main = nullPtr null >>= print+main = nullPtr null >>= printLn
test/basic009/run view
@@ -1,5 +1,8 @@ #!/usr/bin/env bash-idris $@ Main.idr --nocolour --check && echo MAIN-PASS-idris $@ Faulty.idr --nocolour --check && echo FAULTY-PASS-idris $@ Multiple.idr --nocolour --check && echo MULTIPLE-PASS++idris --consolewidth 80 $@ Main.idr --nocolour --check && echo MAIN-PASS+idris --consolewidth 80 $@ Faulty.idr --nocolour --check && echo FAULTY-PASS+idris --consolewidth 80 $@ Multiple.idr --nocolour --check && echo MULTIPLE-PASS++ rm -f *.ibc B/*.ibc
test/basic011/basic011.idr view
@@ -3,14 +3,14 @@ import Data.Hash main : IO ()-main = do print $ hash (the Bits8 3)- print $ hash (the (List Bits8) [3])- print $ hash "hello world"- print $ hash 'a'- print $ hash (the Bits8 3)- print $ hash (the Bits16 3)- print $ hash (the Bits32 3)- print $ hash (the Bits64 3)- print $ hash (the Int 3)- print $ hash (the Integer 3)+main = do printLn $ hash (the Bits8 3)+ printLn $ hash (the (List Bits8) [3])+ printLn $ hash "hello world"+ printLn $ hash 'a'+ printLn $ hash (the Bits8 3)+ printLn $ hash (the Bits16 3)+ printLn $ hash (the Bits32 3)+ printLn $ hash (the Bits64 3)+ printLn $ hash (the Int 3)+ printLn $ hash (the Integer 3)
test/basic011/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ basic011.idr -o basic011+idris $@ basic011.idr -p contrib -o basic011 ./basic011 rm -f basic011 *.ibc
test/basic012/basic012.idr view
@@ -1,7 +1,7 @@ import Data.Vect import Control.Monad.State import Control.Monad.Identity- + VThing : Type VThing = {n : Nat} -> Vect n Int -> Int @@ -31,7 +31,8 @@ AnyST : Type -> Type -> Type AnyST s a = {m : _} -> Monad m => StateT s m a -foost: AnyST Int ()+-- foost : AnyST Int ()+foost : StateT Int Maybe () foost = do x <- get put x @@ -52,11 +53,11 @@ AppendType : Type AppendType = {a, n, m : _} -> Vect n a -> Vect m a -> Vect (n + m) a- + append : AppendType append [] ys = ys append (x :: xs) ys = x :: append xs ys main : IO () main = do putStrLn (baz 42)- print (append [1,2,3] [4,5,6])+ printLn (append [1,2,3] [4,5,6])
+ test/docs001/docs001.idr view
@@ -0,0 +1,20 @@+||| class+||| @ t a type+class C (t : Type) where+ ||| member of class+ m : t++||| type+data A = B++||| type 2+data D a b = E++||| instance of class+instance C A where+ m = B++||| another instance of class+||| @ a parameter type+instance C (D a b) where+ m = E
+ test/docs001/expected view
@@ -0,0 +1,17 @@+Type checking ./docs001.idr+Type class C+ class++Parameters:+ t -- a type++Methods:+ m : C t => t+ member of class+ +Instances:+ C A+ instance of class+ C (D a b)+ another instance of class+ a -- parameter type
+ test/docs001/input view
@@ -0,0 +1,1 @@+:doc C
+ test/docs001/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --quiet --nocolor --consolewidth 80 docs001.idr < input+rm *.ibc
+ test/docs002/docs002.idr view
@@ -0,0 +1,17 @@+module Main++-- Simple test case for type provider documentation.+%language TypeProviders++getType : Int -> IO (Provider Type)+getType 0 = return (Provide Int)+getType _ = return (Provide Bool)++||| Some documentation+%provide (T1 : Type) with getType 0++||| Some other documentation+%provide (T2 : Type) with getType 1++||| Some provided postulate+%provide postulate T3 with getType 0
+ test/docs002/expected view
@@ -0,0 +1,11 @@+Type checking ./docs002.idr+*docs002> T1 : Type+ Some documentation+ +*docs002> T2 : Type+ Some other documentation+ +*docs002> T3 : Int+ Some provided postulate+ +*docs002> Bye bye
+ test/docs002/input view
@@ -0,0 +1,3 @@+:doc T1+:doc T2+:doc T3
+ test/docs002/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --consolewidth 80 --nobanner --nocolor docs002.idr < input+rm *.ibc
+ test/docs003/docs003.idr view
@@ -0,0 +1,9 @@+module docs003++instance [mine] Functor List where+ map m [] = []+ map m (x :: xs) = m x :: map m xs++||| More functors!+instance [another] Functor List where+ map f xs = map @{mine} f xs
+ test/docs003/expected view
@@ -0,0 +1,37 @@+Type checking ./docs003.idr+Type class Functor+ Functors++Parameters:+ f -- the action of the functor on objects++Methods:+ map : Functor f => (m : a -> b) -> f a -> f b+ The action of the functor on morphisms+ +Instances:+ Functor List+ Functor Stream+ Functor Provider+ Functor Binder+ Functor PrimIO+ Functor (IO' ffi)+ Functor Maybe+ Functor (Either e)++Named instances:+ docs003.mine : Functor List+ docs003.another : Functor List+ More functors!++Subclasses:+ Traversable f+ Applicative f+Named instance:+ mine : Functor List+ + +Named instance:+ another : Functor List+ More functors!+
+ test/docs003/input view
@@ -0,0 +1,3 @@+:doc Functor+:doc mine+:doc another
+ test/docs003/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --consolewidth 80 --quiet --nocolor docs003.idr < input+rm *.ibc
test/dsl001/test001.idr view
@@ -35,8 +35,11 @@ If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b + lam_ : TTName -> Expr (a :: G) t -> Expr G (TyFun a t)+ lam_ _ = Lam+ dsl expr- lambda = Lam+ lambda = lam_ variable = Var index_first = stop index_next = pop@@ -93,8 +96,8 @@ testEnv x = [x,x] main : IO ()-main = do { print testFac- print test }+main = do { printLn testFac+ printLn test }
test/dsl002/Resimp.idr view
@@ -156,6 +156,11 @@ = interp env v (\env', v' => do n <- v' interp env' (f n) k) + let_ : _ -> Creator (interpTy a) ->+ Res (a :: gam) (Val () :: gam') (R t) ->+ Res gam gam' (R t)+ let_ _ = Let+ -- run : {static} Res [] [] (R t) -> IO t -- run prog = interp [] prog (\env, res => res) @@ -163,7 +168,7 @@ dsl res variable = id- let = Let+ let = let_ index_first = stop index_next = pop
test/dsl003/DSLPi.idr view
@@ -5,8 +5,11 @@ data Ty = BOOL | INT | UNIT | ARR Ty Ty +arr_ : _ -> Ty -> Ty -> Ty+arr_ _ = ARR+ dsl simple_type- pi = ARR+ pi = arr_ test1 : simple_type (BOOL -> INT -> UNIT) = BOOL `ARR` (INT `ARR` UNIT) test1 = Refl@@ -25,8 +28,11 @@ implicit exprSpec : Expr vars BOOL -> Spec vars exprSpec = ItHolds + forall_ : _ -> (t : Ty) -> Spec (t :: vars) -> Spec vars+ forall_ _ = ForAll+ dsl specs- pi = ForAll+ pi = forall_ variable = Var index_first = FZ index_next = FS
test/effects002/test025.idr view
@@ -30,6 +30,6 @@ main : IO () main = ioe_run (runInit [Dst := (), Src := ()] testMemory)- (\err => print err) (\ok => print ok)+ (\err => printLn err) (\ok => printLn ok)
test/error003/expected view
@@ -1,2 +1,3 @@-ErrorReflection.idr:68:5:When elaborating right hand side of bad:+ErrorReflection.idr:68:5:+When elaborating right hand side of bad: DSL type error: (t(503) => t'(504)) doesn't match ()
test/error003/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ ErrorReflection.idr --nocolour --check+idris --consolewidth 80 $@ ErrorReflection.idr --nocolour --check rm -f *.ibc
test/error004/expected view
@@ -1,6 +1,9 @@-FunErrTest.idr:35:10:When elaborating right hand side of badCadr1:+FunErrTest.idr:35:10:+When elaborating right hand side of badCadr1: When elaborating argument cons1 to function FunErrTest.cadr: Could not prove that [] has at least two elements.-FunErrTest.idr:38:10:When elaborating right hand side of badCadr2:+FunErrTest.idr:38:10:+When elaborating right hand side of badCadr2: When elaborating argument cons2 to function FunErrTest.cadr:- Could not prove that tail [(fromInteger 1)] has at least two elements.+ Could not prove that tail [(fromInteger 1)] has at least two+ elements.
test/error004/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ FunErrTest.idr --nocolour --check+idris --consolewidth 80 $@ FunErrTest.idr --nocolour --check rm -f *.ibc
test/error005/error005.idr view
@@ -18,3 +18,10 @@ notOk : (n : Nat) -> Fin (plus 2 n) notOk n = 2++b0rken : Integer -> Fin 3+b0rken n = fromInteger n++x : Fin 4+x = the (Fin 4) 5+
test/error005/expected view
@@ -1,12 +1,21 @@ error005.idr:13:1:When elaborating right hand side of two: When elaborating argument prf to function Data.Fin.fromInteger: When using 2 as a literal for a Fin 2 - Could not show that 2 is less than 2+ 2 is not strictly less than 2 error005.idr:16:1:When elaborating right hand side of hahaha: When elaborating argument prf to function Data.Fin.fromInteger: When using 0 as a literal for a Fin n - Could not show that 0 is less than n-error005.idr:21:1:When elaborating right hand side of notOk:+ 0 is not strictly less than n+error005.idr:22:1:When elaborating right hand side of notOk: When elaborating argument prf to function Data.Fin.fromInteger: When using 2 as a literal for a Fin (S (S n)) - Could not show that 2 is less than S (S n)+ 2 is not strictly less than S (S n)+error005.idr:23:24:When elaborating right hand side of b0rken:+When elaborating argument prf to function Data.Fin.fromInteger:+ When using n as a literal for a Fin 3 + Could not show that n is less than 3 because n is a bound+ variable instead of a constant Integer+error005.idr:28:1:When elaborating right hand side of x:+When elaborating argument prf to function Data.Fin.fromInteger:+ When using 5 as a literal for a Fin 4 + 5 is not strictly less than 4
test/error005/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --check --nocolour error005.idr+idris --consolewidth 80 $@ --check --nocolour error005.idr rm -f *.ibc
test/ffi001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash idris --quiet --nocolour test022.idr --exec main-rm -f test021 test021a *.ibc+rm -f *.ibc
test/ffi001/test022.idr view
@@ -3,7 +3,7 @@ %dynamic "dummy", "libm", "msvcrt" x : Float-x = unsafePerformIO (mkForeign (FFun "sin" [FFloat] FFloat) 1.6)+x = unsafePerformIO (foreign FFI_C "sin" (Float -> IO Float) 1.6) main : IO () main = putStrLn (show x)
test/ffi002/expected view
@@ -1,1 +1,1 @@-test023.idr:22:21:Type provider error: Always fails+test023.idr:20:21:Type provider error: Always fails
test/ffi002/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet test023.idr -o test023+idris --consolewidth 80 --quiet test023.idr -o test023 rm -f test023 *.ibc
test/ffi002/test023.idr view
@@ -2,8 +2,6 @@ -- Simple test case for trivial type providers. -import Providers- %language TypeProviders -- Provide the Unit type
test/ffi004/test026.idr view
@@ -2,8 +2,6 @@ -- Simple test case for trivial type providers. -import Providers- %language TypeProviders strToType : String -> Type@@ -29,4 +27,3 @@ testBar : Nat testBar = bar-
test/ffi005/Postulate.idr view
@@ -1,7 +1,5 @@ module Main -import Providers- %language TypeProviders bad : IO (Provider Type)
+ test/ffi006/expected view
@@ -0,0 +1,2 @@+Ready to show...+[10, 20, 30, 40]
+ test/ffi006/ffi006.c view
@@ -0,0 +1,14 @@+#include "testHdr.h"++int main() {++ VM* vm = idris_vm();++ ListInt x = cons(vm, 10, cons(vm, 20, nil(vm)));+ ListInt y = cons(vm, 30, cons(vm, 40, nil(vm)));+ ListInt z = addLists(vm, x, y);++ printf("%s\n", showList(vm, z));++ close_vm(vm);+}
+ test/ffi006/ffi006.idr view
@@ -0,0 +1,30 @@+import Data.List++addLists : List Int -> List Int -> List Int+addLists xs ys = xs ++ ys++nil : List Int+nil = []++cons : Int -> List Int -> List Int+cons x xs = x :: xs++show' : List Int -> IO String+show' xs = do putStrLn "Ready to show..."+ return (show xs)++testList : FFI_Export FFI_C "testHdr.h" []+testList = Data (List Int) "ListInt" $+ Data (List Nat) "ListNat" $+ Fun addLists "addLists" $+ Fun nil "nil" $+ Fun cons "cons" $+ Data Nat "Nat" $+ Fun Strings.length "lengthS" $+ Fun show' "showList" $+ End++-- main : IO ()+-- main = do s <- show' 42+-- putStrLn s +
+ test/ffi006/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+idris $@ ffi006.idr --interface -o ffi006.o+cc ffi006.c ffi006.o `idris --include` `idris --link` -o ffi006+./ffi006+rm -f ffi006 *.ibc *.o *.h
+ test/interactive007/expected view
@@ -0,0 +1,1 @@+Idris> *Data/ZZ> *Data/ZZ> *Data/ZZ> *Data/ZZ> Bye bye
+ test/interactive007/input view
@@ -0,0 +1,4 @@+:module Data.ZZ+:module Data.ZZ+:r+:module Data.ZZ
+ test/interactive007/run view
@@ -0,0 +1,2 @@+#!/usr/bin/env bash+idris -p contrib --nobanner --nocolor < input
test/io002/test008.idr view
@@ -22,7 +22,7 @@ let x = "bar" putStrLn (show (getVal x 7 testlist)) let ((y, z) :: _) = testlist- print z+ printLn z case lookup x testlist of Just v => putStrLn (show v) Nothing => putStrLn "Not there!"
test/io003/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris $@ test018.idr -o test018-idris $@ test018a.idr -o test018a+idris $@ test018.idr -p contrib -o test018+idris $@ test018a.idr -p contrib -o test018a ./test018 #./test018a rm -f test018 test018a *.ibc
test/io003/test018a.idr view
@@ -27,7 +27,7 @@ repeatIO : Int -> IO () repeatIO 0 = return ()-repeatIO n = do print n+repeatIO n = do printLn n run mainProc repeatIO (n - 1)
test/literate001/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris $@ test003a.lidr --check-idris $@ test003.lidr -o test003+idris --consolewidth 80 $@ test003a.lidr --check+idris --consolewidth 80 $@ test003.lidr -o test003 ./test003 rm -f test003 test003.ibc Lit.ibc
test/primitives001/test005.idr view
@@ -7,9 +7,9 @@ tlist = [1, 2, 3, 4, 5] main : IO ()-main = do print (abs (-8))- print (abs (S Z))- print (span isAlpha tstr)- print (break isDigit tstr)- print (span (\x => x < 3) tlist)- print (break (\x => x > 2) tlist)+main = do printLn (abs (-8))+ printLn (abs (S Z))+ printLn (span isAlpha tstr)+ printLn (break isDigit tstr)+ printLn (span (\x => x < 3) tlist)+ printLn (break (\x => x > 2) tlist)
test/primitives003/expected view
@@ -16,8 +16,6 @@ False True False-True-False False True False
test/primitives003/test038.idr view
@@ -40,9 +40,6 @@ -- Booleans putStrLn . show $ test True True putStrLn . show $ test True False- -- Float- putStrLn . show $ test 1.0 1.0- putStrLn . show $ test 1.0 2.0 -- Maybe putStrLn . show $ test (Just "hello") (Just "hello") putStrLn . show $ test (Just "hello") (Just "world")
test/proof002/expected view
@@ -1,9 +1,10 @@-Reflect.idr:208:38:When elaborating right hand side of testReflect1:+Reflect.idr:208:38:+When elaborating right hand side of testReflect1: When elaborating an application of function Reflect.getJust: Can't unify- IsJust (Just x1)+ IsJust (Just x1) (Type of ItIsJust) with- IsJust (prove (getProof x))+ IsJust (prove (getProof x)) (Expected type) Specifically: Can't unify
test/proof002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test030.idr --check --nocolour-idris $@ test030a.idr --check --nocolour+idris --consolewidth 80 $@ test030.idr --check --nocolour+idris --consolewidth 80 $@ test030a.idr --check --nocolour rm -f *.ibc
test/proof003/test015.idr view
@@ -72,10 +72,10 @@ main : IO () main = do let Just bin1 = natToBin 8 42- print bin1+ printLn bin1 let Just bin2 = natToBin 8 89- print bin2- print (adc bin1 bin2 b0)+ printLn bin2+ printLn (adc bin1 bin2 b0)
+ test/proof008/ClaimAndUnfocus.idr view
@@ -0,0 +1,17 @@+module ClaimAndUnfocus++foo : Nat -> Nat+foo = ?foo_rhs++---------- Proofs ----------++ClaimAndUnfocus.foo_rhs = proof+ claim bar Nat -> Nat -> Nat+ unfocus+ intro x+ exact bar x x+ intro x,y+ refine plus+ refine x+ refine y+
+ test/proof008/expected view
+ test/proof008/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --check $@ ClaimAndUnfocus.idr+rm -f *.ibc
test/quasiquote001/expected view
@@ -1,5 +1,5 @@ (App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 8 0) (UN Unit) (TType (UVar -1)))) (P (DCon 0 0) (UN MkUnit) (P (TCon 0 0) (UN Unit) Erased))) (App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 8 0) (UN Unit) (TType (UVar -1)))) (P (DCon 0 0) (UN MkUnit) (P (TCon 0 0) (UN Unit) Erased))) (App (P (DCon 0 1) (NS (UN Nil) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 0)))) (P (TCon 8 0) (UN Unit) (TType (UVar -1)))))) ---------------(App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 48))) (TType (UVar 50))) (App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 52))) (App (App (App (App (P (DCon 0 4) (NS (UN MkPair) ["Builtins"]) (Bind (UN A) (Pi (TType (UVar -1))) (Bind (UN B) (Pi (TType (UVar -1))) (Bind (UN a) (Pi (V 1)) (Bind (UN b) (Pi (V 1)) (App (App (P (TCon 0 0) (NS (UN Pair) ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 42))) (TType (UVar 44))) (P (TCon 8 0) (NS (UN Nat) ["Nat", "Prelude"]) (TType (UVar -1)))) (P (TCon 8 0) (NS (UN Nat) ["Nat", "Prelude"]) (TType (UVar -1))))) (App (P (DCon 0 1) (NS (UN Nil) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 0)))) (TType (UVar 54)))))+(App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 32))) (TType (UVar 34))) (App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 36))) (App (App (App (App (P (DCon 0 4) (NS (UN MkPair) ["Builtins"]) (Bind (UN A) (Pi (TType (UVar -1))) (Bind (UN B) (Pi (TType (UVar -1))) (Bind (UN a) (Pi (V 1)) (Bind (UN b) (Pi (V 1)) (App (App (P (TCon 0 0) (NS (UN Pair) ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 30))) (TType (UVar 32))) (P (TCon 8 0) (NS (UN Nat) ["Nat", "Prelude"]) (TType (UVar -1)))) (P (TCon 8 0) (NS (UN Nat) ["Nat", "Prelude"]) (TType (UVar -1))))) (App (P (DCon 0 1) (NS (UN Nil) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 0)))) (TType (UVar 38))))) ---------------(App (App (App (App (P (DCon 0 4) (NS (UN MkPair) ["Builtins"]) (Bind (UN A) (Pi (TType (UVar -1))) (Bind (UN B) (Pi (TType (UVar -1))) (Bind (UN a) (Pi (V 1)) (Bind (UN b) (Pi (V 1)) (App (App (P (TCon 0 0) (NS (UN Pair) ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 42))) (TType (UVar 44))) (App (App (App (App (P (DCon 0 4) (NS (UN MkPair) ["Builtins"]) (Bind (UN A) (Pi (TType (UVar -1))) (Bind (UN B) (Pi (TType (UVar -1))) (Bind (UN a) (Pi (V 1)) (Bind (UN b) (Pi (V 1)) (App (App (P (TCon 0 0) (NS (UN Pair) ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 42))) (TType (UVar 44))) (TType (UVar 48))) (TType (UVar 48)))) (App (App (App (App (P (DCon 0 4) (NS (UN MkPair) ["Builtins"]) (Bind (UN A) (Pi (TType (UVar -1))) (Bind (UN B) (Pi (TType (UVar -1))) (Bind (UN a) (Pi (V 1)) (Bind (UN b) (Pi (V 1)) (App (App (P (TCon 0 0) (NS (UN Pair) ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 42))) (TType (UVar 44))) (TType (UVar 48))) (TType (UVar 48))))+(App (App (App (App (P (DCon 0 4) (NS (UN MkPair) ["Builtins"]) (Bind (UN A) (Pi (TType (UVar -1))) (Bind (UN B) (Pi (TType (UVar -1))) (Bind (UN a) (Pi (V 1)) (Bind (UN b) (Pi (V 1)) (App (App (P (TCon 0 0) (NS (UN Pair) ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 30))) (TType (UVar 32))) (App (App (App (App (P (DCon 0 4) (NS (UN MkPair) ["Builtins"]) (Bind (UN A) (Pi (TType (UVar -1))) (Bind (UN B) (Pi (TType (UVar -1))) (Bind (UN a) (Pi (V 1)) (Bind (UN b) (Pi (V 1)) (App (App (P (TCon 0 0) (NS (UN Pair) ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 30))) (TType (UVar 32))) (TType (UVar 32))) (TType (UVar 32)))) (App (App (App (App (P (DCon 0 4) (NS (UN MkPair) ["Builtins"]) (Bind (UN A) (Pi (TType (UVar -1))) (Bind (UN B) (Pi (TType (UVar -1))) (Bind (UN a) (Pi (V 1)) (Bind (UN b) (Pi (V 1)) (App (App (P (TCon 0 0) (NS (UN Pair) ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 30))) (TType (UVar 32))) (TType (UVar 32))) (TType (UVar 32))))
test/quasiquote003/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --check NoInfer.idr+idris --consolewidth 80 $@ --check NoInfer.idr rm -f *.ibc
test/quasiquote004/expected view
@@ -1,2 +1,3 @@-Quasiquote004.idr:50:25:When elaborating right hand side of Quasiquote004.getMeNat':+Quasiquote004.idr:50:25:+When elaborating right hand side of Quasiquote004.getMeNat': Not a Nat goal
test/quasiquote004/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --check --nocolour Quasiquote004.idr+idris --consolewidth 80 $@ --check --nocolour Quasiquote004.idr rm -f *.ibc
+ test/quasiquote005/Quasiquote005.idr view
@@ -0,0 +1,22 @@+module Quasiquote005++-- Test Raw quasiquotes++test : the Language.Reflection.Raw `(plus (S Z) (S Z)) =+ RApp (RApp (Var (NS (UN "plus") ["Nat", "Prelude"]))+ (RApp (Var (NS (UN "S") ["Nat", "Prelude"]))+ (Var (NS (UN "Z") ["Nat", "Prelude"]))))+ (RApp (Var (NS (UN "S") ["Nat", "Prelude"]))+ (Var (NS (UN "Z") ["Nat", "Prelude"])))+test = Refl++firstAddend : Raw -> Maybe Raw+firstAddend `(plus ~first ~_) = Just first+firstAddend _ = Nothing++firstAddendOk : firstAddend (RApp (RApp (Var (NS (UN "plus") ["Nat", "Prelude"]))+ (RApp (Var (NS (UN "S") ["Nat", "Prelude"]))+ (Var (NS (UN "Z") ["Nat", "Prelude"]))))+ (Var (NS (UN "Z") ["Nat", "Prelude"]))) =+ the (Maybe Raw) (Just `(S Z))+firstAddendOk = Refl
+ test/quasiquote005/expected view
+ test/quasiquote005/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --check --nocolour Quasiquote005.idr+rm -f *.ibc
test/records001/test011.idr view
@@ -20,9 +20,9 @@ main : IO () main = do let x = record { name = "foo", more_things = reverse ["a","b"] } testFoo- print $ name x- print $ name person- print $ things x- print $ more_things x- print $ age (record { age = 25 } person)+ printLn $ name x+ printLn $ name person+ printLn $ things x+ printLn $ more_things x+ printLn $ age (record { age = 25 } person)
test/records003/records003.idr view
@@ -38,10 +38,10 @@ test = next_year idm_gbg main : IO ()-main = do print (record { event->organiser->name } test)- print (record { event->organiser->age } test)- print (record { event->organiser->age } idm_gbg)- print (record { organiser->age } test)- print (record { organiser->age } idm_gbg)- print (record { year } idm_gbg)+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)
test/reg002/reg012.idr view
@@ -30,4 +30,4 @@ swap (x :: y :: xs) = (y :: x :: (swap xs)) main : IO ()-main = print (swap [1,2,3,4,5])+main = printLn (swap [1,2,3,4,5])
test/reg003/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris --check reg003.idr-idris --check reg003a.idr+idris --consolewidth 80 --check reg003.idr+idris --consolewidth 80 --check reg003a.idr rm -f *.ibc
test/reg004/reg004.idr view
@@ -13,4 +13,4 @@ r2 = r main : IO ()-main = do print (h True); print (h False)+main = do printLn (h True); printLn (h False)
test/reg006/expected view
@@ -1,1 +1,2 @@-reg006.idr:17:1:RBTree.lookup is possibly not total due to: RBTree.case block in lookup+reg006.idr:17:1:+RBTree.lookup is possibly not total due to: RBTree.case block in lookup
test/reg006/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg006.idr --check+idris --consolewidth 80 $@ reg006.idr --check rm -f *.ibc
test/reg007/expected view
@@ -1,9 +1,9 @@ reg007.lidr:8:1:A.n is already defined reg007.lidr:12:11:When elaborating right hand side of hurrah: Can't unify- n = lala+ n = lala (Type of isSame) with- 0 = 1+ 0 = 1 (Expected type) Specifically: Can't unify
test/reg007/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --nocolour --check $@ reg007.lidr+idris --consolewidth 80 --nocolour --check $@ reg007.lidr rm -f *.ibc
test/reg010/expected view
@@ -1,2 +1,3 @@-reg010.idr:5:15:When elaborating left hand side of with block in usubst.unsafeSubst:+reg010.idr:5:15:+When elaborating left hand side of with block in usubst.unsafeSubst: Can't match on with block in usubst.unsafeSubst warg a P x x px
test/reg010/run view
@@ -1,2 +1,2 @@ #!/usr/bin/env bash-idris $@ reg010.idr --check --nocolour+idris --consolewidth 80 $@ reg010.idr --check --nocolour
test/reg013/reg013.idr view
@@ -2,7 +2,7 @@ main : IO () main = do- print $ prim_lenString "hallo"- print $ prim_lenString "1"- print $ prim_lenString ""+ printLn $ prim_lenString "hallo"+ printLn $ prim_lenString "1"+ printLn $ prim_lenString ""
test/reg016/reg016.idr view
@@ -1,11 +1,11 @@ module Main main : IO ()-main = do print $ the Integer 429496729500000000000000--- print $ the Integer 4294967296--- print $ the Integer 4294967297--- print $ the Int 4294967295--- print $ the Int 4294967296--- print $ the Int 4294967297+main = do printLn $ the Integer 429496729500000000000000+-- printLn $ the Integer 4294967296+-- printLn $ the Integer 4294967297+-- printLn $ the Int 4294967295+-- printLn $ the Int 4294967296+-- printLn $ the Int 4294967297
test/reg017/reg017.idr view
@@ -10,4 +10,4 @@ foo {t} a {prfA = p} b c {prfBC} = b main : IO ()-main = print $ foo 3 4 4+main = printLn $ foo 3 4 4
test/reg018/expected view
@@ -1,5 +1,10 @@-reg018a.idr:16:1:conat.minusCoNat is possibly not total due to recursive path conat.minusCoNat-reg018a.idr:21:1:conat.loopForever is possibly not total due to: conat.minusCoNat-reg018b.idr:8:1:A.showB is possibly not total due to recursive path A.showB-reg018c.idr:21:1:CodataTest.inf is possibly not total due to: with block in CodataTest.inf-reg018d.idr:8:1:Main.pull is not total as there are missing cases+reg018a.idr:16:1:+conat.minusCoNat is possibly not total due to recursive path conat.minusCoNat+reg018a.idr:21:1:+conat.loopForever is possibly not total due to: conat.minusCoNat+reg018b.idr:8:1:+A.showB is possibly not total due to recursive path A.showB+reg018c.idr:21:1:+CodataTest.inf is possibly not total due to: with block in CodataTest.inf+reg018d.idr:8:1:+Main.pull is not total as there are missing cases
test/reg018/reg018d.idr view
@@ -12,4 +12,4 @@ (v, x::vs) main : IO ()-main = print (pull FZ [0, 1, 2])+main = printLn (pull FZ [0, 1, 2])
test/reg018/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris $@ reg018a.idr --check-idris $@ reg018b.idr --check-idris $@ reg018c.idr --check-idris $@ reg018d.idr --check+idris --consolewidth 80 $@ reg018a.idr --check+idris --consolewidth 80 $@ reg018b.idr --check+idris --consolewidth 80 $@ reg018c.idr --check+idris --consolewidth 80 $@ reg018d.idr --check rm *.ibc
test/reg023/expected view
@@ -1,5 +1,5 @@ reg023.idr:7:5:When elaborating right hand side of bad: Can't unify- [94mNat[0m+ [94mNat[0m (Type of [91m0[0m) with- [92mf[0m [94mNat[0m+ [92mf[0m [94mNat[0m (Expected type)
test/reg023/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg023.idr --check+idris --consolewidth 80 $@ reg023.idr --check rm -f *.ibc
test/reg027/expected view
@@ -1,3 +1,4 @@ <<int fn>> 6-reg027a.idr:9:10:Overlapping instance: Show (Int -> a) already defined+reg027a.idr:9:10:+Overlapping instance: Show (Int -> a) already defined
test/reg027/reg027.idr view
@@ -14,7 +14,7 @@ instance Applicative (\x => Int -> x) where pure v = \x => v- (<$>) f a = \x => f x (a x)+ (<*>) f a = \x => f x (a x) instance Monad IntFn where f >>= k = \x => k (f x) x@@ -27,6 +27,6 @@ \x => show val main : IO ()-main = do print dbl+main = do printLn dbl putStrLn (foo 3)
test/reg027/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris $@ reg027.idr -o reg027+idris --consolewidth 80 $@ reg027.idr -o reg027 ./reg027-idris $@ reg027a.idr --check+idris --consolewidth 80 $@ reg027a.idr --check rm -f reg027 *.ibc
test/reg028/expected view
@@ -1,2 +1,4 @@-reg028.idr:5:1:tbad.bad is possibly not total due to: with block in tbad.bad-reg028a.idr:11:1:tbad.qsort' is possibly not total due to: with block in tbad.qsort'+reg028.idr:5:1:+tbad.bad is possibly not total due to: with block in tbad.bad+reg028a.idr:11:1:+tbad.qsort' is possibly not total due to: with block in tbad.qsort'
test/reg028/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg028.idr --check-idris $@ reg028a.idr --check+idris --consolewidth 80 $@ reg028.idr --check+idris --consolewidth 80 $@ reg028a.idr --check rm -f *.ibc
test/reg029/reg029.idr view
@@ -7,5 +7,5 @@ main : IO () main = do- print !(getEnv "IDRIS_REG029_NONEXISTENT_VAR")- print !(getEnv "IDRIS_REG029_EXISTENT_VAR")+ printLn !(getEnv "IDRIS_REG029_NONEXISTENT_VAR")+ printLn !(getEnv "IDRIS_REG029_EXISTENT_VAR")
test/reg031/reg031.idr view
@@ -1,7 +1,7 @@ module Main main : IO ()-main = print . map val . unpack $ "\x0a\x80\xC9\xFF\n3\n4"+main = printLn . map val . unpack $ "\x0a\x80\xC9\xFF\n3\n4" where -- make the values positive if the backend has signed chars val : Char -> Int
test/reg034/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --check reg034.idr+idris --consolewidth 80 --check reg034.idr rm -f reg034 *.ibc
test/reg035/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris --check reg035.idr-idris --check reg035a.lidr-idris --check reg035b.idr+idris --consolewidth 80 --check reg035.idr+idris --consolewidth 80 --check reg035a.lidr+idris --consolewidth 80 --check reg035b.idr rm -f *.ibc
test/reg040/reg040.idr view
@@ -4,4 +4,4 @@ io = return 42 main : IO ()-main = print $ unsafePerformIO io+main = printLn $ unsafePerformIO io
test/reg041/ott.idr view
@@ -37,6 +37,6 @@ EQ (pi s t) f (pi s' t') g = pi s $ \x => pi s' $ \y => EQ s x s' y ~> EQ (t x) (f x) (t' y) (g y) EQ _ _ _ _ = zero -example : <| id == id in (two ~> two) |>+example : <| (id == id in (two ~> two)) |> example = ?prf
test/reg042/reg042.idr view
@@ -21,4 +21,4 @@ -- Here, we'd apply the not-a-function to the erased argument 4, -- which would make the program go wrong. main : IO ()-main = print $ g (proj 3 f 4)+main = printLn $ g (proj 3 f 4)
test/reg044/expected view
@@ -1,8 +1,8 @@ reg044.idr:4:4:When elaborating right hand side of Main.pf: Can't unify- [95mb[0m [94m=[0m [95mb[0m+ [95mb[0m [94m=[0m [95mb[0m (Type of [91mRefl[0m) with- [95ma[0m [94m=[0m [95mb[0m+ [95ma[0m [94m=[0m [95mb[0m (Expected type) Specifically: Can't unify
test/reg044/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris reg044.idr --check+idris --consolewidth 80 reg044.idr --check rm -f *.ibc
test/reg045/reg045.idr view
@@ -15,5 +15,5 @@ foo = (1 :: 2 :: 3 :: Nil) main : IO ()-main = print foo+main = printLn foo
test/reg048/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg048.idr -o reg048+idris $@ reg048.idr -p contrib -o reg048 ./reg048 rm -f reg048 *.ibc
test/reg049/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --nocolour --check $@ reg049.idr+idris --consolewidth 80 --nocolour --check $@ reg049.idr rm -f *.ibc
test/reg050/expected view
@@ -1,28 +1,10 @@-badbangop.idr:16:1:When elaborating right hand side of opUse:-When elaborating an application of function Prelude.Monad.>>=:- Can't unify- List Integer- with- argTy -> retTy- - Specifically:- Can't unify- List- with- \{uv0} => argTy -> uv-./baddoublebang.idr:6:26: error: not- a terminator, expected: "$",- "$>", "&&", "*", "+", "++", "-",- "->", ".", "/", "/=", "::", ";",- "<", "<#>", "<$", "<$>", "<*>",- "<+>", "<->", "<<", "<=", "<|>",- "=", "==", ">", ">=", ">>",- ">>=", "\\\\", "`", "in", "||",- "~=~",- ambiguous use of a left-associative operator,- ambiguous use of a non-associative operator,- ambiguous use of a right-associative operator,- end of input, function argument,- matching application expression+./badbangop.idr:7:1: error: ! is+ not a valid+ operator, expected: space+(!) : List a -> Nat -> Maybe a +^ +./baddoublebang.idr:6:28: error: unexpected+ Operator without known fixity:+ !!, expected: space doubleBang mmn = do pure !!mmn - ^ + ^
+ test/reg051-disabled/expected view
+ test/reg051-disabled/reg051.idr view
@@ -0,0 +1,99 @@+-- Test for problem with parameter propagation in fromState'++data StateTy : Type where+ STInt : StateTy+ STString : StateTy+ STMaybe : StateTy -> StateTy+ STList : StateTy -> StateTy++interpSTy : StateTy -> Type+interpSTy STInt = Int+interpSTy STString = String+interpSTy (STMaybe a) = Maybe (interpSTy a)+interpSTy (STList a) = List (interpSTy a)++data State : StateTy -> Type where+ MkState : (t : StateTy) -> Ptr -> State t++abstract+data StateC : StateTy -> Type where+ MkStateC : Int -> (t : StateTy) -> Ptr -> StateC t++isObj : Ptr -> IO Bool+isObj p = do+ "object" <- mkForeign (FFun "typeof %0" [FPtr] FString) p+ | _ => pure False+ pure True++stateVarName : String+stateVarName = "__IDR__IQUERY__STATE__"++stateVarExists : IO Bool+stateVarExists = do+ o <- mkForeign (FFun ("typeof " ++ stateVarName) [] FString) + pure $ if o == "object" then True else False++initStateVar : IO Ptr+initStateVar = mkForeign (FFun (stateVarName ++ " = {count: 0}") [] FPtr)++getStateVar : IO (Maybe Ptr) +getStateVar = case !stateVarExists of+ True => map Just $ mkForeign (FFun stateVarName [] FPtr)+ False => pure Nothing++getStateVar' : IO Ptr+getStateVar' = case !getStateVar of+ Just s => pure s+ Nothing => initStateVar++stateCExists : Ptr -> Int -> IO Bool+stateCExists c n = do+ r <- mkForeign (FFun "typeof %0[%1]" [FPtr,FInt] FString) c n+ pure $ if r == "object" then True else False++incCount : Ptr -> IO Int+incCount c = do+ n <- mkForeign (FFun "%0.count" [FPtr] FInt) c+ mkForeign (FFun "%0.count++" [FPtr] FUnit) c+ pure n++infixl 5 =>>+public+(=>>) : IO (Maybe (State a)) -> (State a -> IO (Maybe b)) + -> IO (Maybe b)+s =>> f = do+ (Just s') <- s+ | Nothing => pure Nothing+ f s'++infixl 5 :=>+public+(:=>) : IO (Maybe (State a)) -> (State a -> IO ()) -> IO Bool+(:=>) s f = do+ (Just s') <- s+ | Nothing => pure False+ f s'+ pure True++public +access : Nat -> State (STList t) -> IO (Maybe (State t))+access n (MkState (STList t) p) = do+ r <- mkForeign (FFun "%0.val[%1]" [FPtr,FInt] FPtr) p (fromNat n)+ True <- isObj r+ | False => pure Nothing+ pure $ Just $ MkState t r++fromState' : State t -> IO (interpSTy t)+fromState' (MkState STInt p) = mkForeign (FFun "%0.val" [FPtr] FInt) p+fromState' (MkState STString p) = mkForeign (FFun "%0.val" [FPtr] FString) p+fromState' (MkState (STMaybe a) p) = do+ isNull <- (mkForeign (FFun "(%0.val == null).toString()" [FPtr] FString) p) + case isNull == "true" of+ True => pure Nothing+ False => pure $ Just !(fromState' (MkState a p))+fromState' (MkState (STList a) p) = do+ n <- mkForeign (FFun "%0.val.length" [FPtr] FInt) p+ ps <- sequence $ map + (\n => mkForeign (FFun "%0.val[%1]" [FPtr,FInt] FPtr) p n) [0..(n-1)]+ sequence $ map (\p' => fromState' (MkState a p')) ps+
+ test/reg051-disabled/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ reg051.idr --check+rm -f *.ibc
− test/reg051/expected
− test/reg051/reg051.idr
@@ -1,99 +0,0 @@--- Test for problem with parameter propagation in fromState'--data StateTy : Type where- STInt : StateTy- STString : StateTy- STMaybe : StateTy -> StateTy- STList : StateTy -> StateTy--interpSTy : StateTy -> Type-interpSTy STInt = Int-interpSTy STString = String-interpSTy (STMaybe a) = Maybe (interpSTy a)-interpSTy (STList a) = List (interpSTy a)--data State : StateTy -> Type where- MkState : (t : StateTy) -> Ptr -> State t--abstract-data StateC : StateTy -> Type where- MkStateC : Int -> (t : StateTy) -> Ptr -> StateC t--isObj : Ptr -> IO Bool-isObj p = do- "object" <- mkForeign (FFun "typeof %0" [FPtr] FString) p- | _ => pure False- pure True--stateVarName : String-stateVarName = "__IDR__IQUERY__STATE__"--stateVarExists : IO Bool-stateVarExists = do- o <- mkForeign (FFun ("typeof " ++ stateVarName) [] FString) - pure $ if o == "object" then True else False--initStateVar : IO Ptr-initStateVar = mkForeign (FFun (stateVarName ++ " = {count: 0}") [] FPtr)--getStateVar : IO (Maybe Ptr) -getStateVar = case !stateVarExists of- True => map Just $ mkForeign (FFun stateVarName [] FPtr)- False => pure Nothing--getStateVar' : IO Ptr-getStateVar' = case !getStateVar of- Just s => pure s- Nothing => initStateVar--stateCExists : Ptr -> Int -> IO Bool-stateCExists c n = do- r <- mkForeign (FFun "typeof %0[%1]" [FPtr,FInt] FString) c n- pure $ if r == "object" then True else False--incCount : Ptr -> IO Int-incCount c = do- n <- mkForeign (FFun "%0.count" [FPtr] FInt) c- mkForeign (FFun "%0.count++" [FPtr] FUnit) c- pure n--infixl 5 =>>-public-(=>>) : IO (Maybe (State a)) -> (State a -> IO (Maybe b)) - -> IO (Maybe b)-s =>> f = do- (Just s') <- s- | Nothing => pure Nothing- f s'--infixl 5 :=>-public-(:=>) : IO (Maybe (State a)) -> (State a -> IO ()) -> IO Bool-(:=>) s f = do- (Just s') <- s- | Nothing => pure False- f s'- pure True--public -access : Nat -> State (STList t) -> IO (Maybe (State t))-access n (MkState (STList t) p) = do- r <- mkForeign (FFun "%0.val[%1]" [FPtr,FInt] FPtr) p (fromNat n)- True <- isObj r- | False => pure Nothing- pure $ Just $ MkState t r--fromState' : State t -> IO (interpSTy t)-fromState' (MkState STInt p) = mkForeign (FFun "%0.val" [FPtr] FInt) p-fromState' (MkState STString p) = mkForeign (FFun "%0.val" [FPtr] FString) p-fromState' (MkState (STMaybe a) p) = do- isNull <- (mkForeign (FFun "(%0.val == null).toString()" [FPtr] FString) p) - case isNull == "true" of- True => pure Nothing- False => pure $ Just !(fromState' (MkState a p))-fromState' (MkState (STList a) p) = do- n <- mkForeign (FFun "%0.val.length" [FPtr] FInt) p- ps <- sequence $ map - (\n => mkForeign (FFun "%0.val[%1]" [FPtr,FInt] FPtr) p n) [0..(n-1)]- sequence $ map (\p' => fromState' (MkState a p')) ps-
− test/reg051/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg051.idr --check-rm -f *.ibc
test/reg052/reg052.idr view
@@ -5,4 +5,4 @@ impure_int = return 41 main : IO ()-main = impure_int >>= impure_op . prim__zextInt_B64 >>= print+main = impure_int >>= impure_op . prim__zextInt_B64 >>= printLn
test/reg053/four.idr view
@@ -5,5 +5,5 @@ traverseFourFunctor : Applicative f -> (x -> f b) -> FourFunctor x -> f (FourFunctor b) traverseFourFunctor constr f (Four w x y z) - = pure Four <$> (f w) <$> (f x) <$> (f y) <$> (f z)+ = pure Four <*> (f w) <*> (f x) <*> (f y) <*> (f z)
test/reg054/run view
@@ -1,2 +1,2 @@ #!/usr/bin/env bash-idris $@ reg054.idr --check+idris --consolewidth 80 $@ reg054.idr --check
test/reg055/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris $@ reg055.idr --check-idris $@ reg055a.idr --check+idris --consolewidth 80 $@ reg055.idr --check+idris --consolewidth 80 $@ reg055a.idr --check rm -f *.ibc
test/reg056/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg056.idr -o reg056+idris --consolewidth 80 $@ reg056.idr -o reg056 rm -f *.ibc
+ test/reg058/expected view
+ test/reg058/implicits.idr view
@@ -0,0 +1,14 @@+%default total++InterpBool : () -> Type+InterpBool () = {x : Type} -> x -> Nat++class IdrisBug (u : ()) where+ idrisBug : InterpBool u++instance IdrisBug () where+ idrisBug _ = Z++f : Nat+f = idrisBug {u = ()} 'a'+
+ test/reg058/implicits2.idr view
@@ -0,0 +1,19 @@+import Data.Vect++impTy : Bool -> Type+impTy True = Int+impTy False = {n : Nat} -> Vect n Int -> Vect n Int++wibble : impTy False+wibble [] = [] +wibble (x :: xs) = x * 2 :: wibble xs++wobble : (b : Bool) -> impTy b+wobble True = 42+wobble False = wibble++foo : Vect 4 Int+foo = wobble False [1,2,3,4]++bar : Int+bar = wobble True
+ test/reg058/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+idris $@ implicits.idr --check+idris $@ implicits2.idr --check++rm -f *.ibc
+ test/reg059/expected view
+ test/reg059/reg059.idr view
@@ -0,0 +1,8 @@+class Monad m => ContainerMonad (m : Type -> Type) where+ Elem : a -> m a -> Type+ tagElem : (mx : m a) -> m (x : a ** Elem x mx)++class Monad m => ContainerMonad2 a (m : Type -> Type) where+ Elem2 : a -> m a -> Type+ tagElem2 : (mx : m a) -> m (x : a ** Elem2 x mx)+
+ test/reg059/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ reg059.idr --check+rm -f *.ibc
+ test/reg060/expected view
+ test/reg060/reg060.idr view
@@ -0,0 +1,12 @@++class MyFunctor (f : Type -> Type) where+ mymap : (m : a -> b) -> f a -> f b++data Foo x y = Bar y++instance MyFunctor (Foo m) where+ mymap m x = ?wibble++instance [foo] Functor m => MyFunctor m where+ mymap m x = map m x+
+ test/reg060/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ reg060.idr --check+rm -f *.ibc
test/sourceLocation001/SourceLoc.idr view
@@ -36,7 +36,7 @@ Var : (i : Fin n) -> Tm ctxt (index i ctxt) Lam : Tm (t::ctxt) t' -> Tm ctxt (Arr t t') App : Tm ctxt (Arr t t') -> Tm ctxt t -> Tm ctxt t'- ||| A term that makes the program halt and print where it halted+ ||| A term that makes the program halt and printLn where it halted Die : {default tactics { sourceLocation } loc : SourceLocation} -> Tm ctxt t data Env : Vect n Ty -> Type where@@ -54,6 +54,8 @@ run (App f x) env = !(run f env) !(run x env) run (Die {loc}) _ = Left loc + lam_ : _ -> Tm (t::ctxt) t' -> Tm ctxt (Arr t t')+ lam_ _ = Lam exec : Tm [] t -> IO () exec tm = case run tm [] of@@ -64,7 +66,7 @@ variable = Var index_first = FZ index_next = FS- lambda = Lam+ lambda = lam_ testTerm1 : Tm [] (Arr U U) testTerm1 = lang (\x=>Die)@@ -81,11 +83,11 @@ namespace Main main : IO () main = do putStrLn "Testing using definition"- print fromRHS+ printLn fromRHS putStrLn "Testing using inline tactics"- print fromProofScript+ printLn fromProofScript putStrLn "Testing using metavariable with later definition"- print fromMetavar+ printLn fromMetavar putStrLn "-----------------------" sequence_ $ with List [ exec testTerm1 , exec testTerm2
test/sourceLocation001/expected view
@@ -3,9 +3,9 @@ Testing using inline tactics FileLoc "SourceLoc.idr" (20, 17) (20, 17) Testing using metavariable with later definition-FileLoc "SourceLoc.idr" (96, 16) (96, 16)+FileLoc "SourceLoc.idr" (98, 16) (98, 16) ----------------------- Success!-Error at FileLoc "SourceLoc.idr" (70, 23) (70, 23)+Error at FileLoc "SourceLoc.idr" (72, 23) (72, 23) Success! Success!
test/sugar001/test007.idr view
@@ -19,7 +19,7 @@ instance Applicative Eval where pure x = MkEval (\e => Just x) - (<$>) (MkEval f) (MkEval g) = MkEval (\x => appAux (f x) (g x)) where+ (<*>) (MkEval f) (MkEval g) = MkEval (\x => appAux (f x) (g x)) where appAux : Maybe (a -> b) -> Maybe a -> Maybe b appAux (Just fx) (Just gx) = Just (fx gx) appAux _ _ = Nothing@@ -35,7 +35,7 @@ } main : IO ()-main = do print [| (\x => x *2) (Just 4) |]- print [| plus (Just 4) (Just 5) |]- print (runEval [("x",21), ("y", 20)] (Add (Val 1) (Add (Var "x") (Var "y"))))- print (runEval [("x",21)] (Add (Val 1) (Add (Var "x") (Var "y"))))+main = do printLn [| (\x => x *2) (Just 4) |]+ printLn [| plus (Just 4) (Just 5) |]+ printLn (runEval [("x",21), ("y", 20)] (Add (Val 1) (Add (Var "x") (Var "y"))))+ printLn (runEval [("x",21)] (Add (Val 1) (Add (Var "x") (Var "y"))))
test/sugar004/sugar004.idr view
@@ -9,7 +9,7 @@ main : IO () main = do [p, a] <- getArgs | [p] => putStrLn "No arguments!" | (x :: y :: _) => putStrLn "Too many arguments!"- print (foo (Just (cast a)))+ printLn (foo (Just (cast a))) {-
test/sugar005/As.idr view
@@ -24,13 +24,13 @@ namespace Main main : IO ()- main = do print $ isS 0- print $ isS 1- print $ hasS [0,0,0]- print $ hasS [0,1,2]- print $ isSS 5- print $ isSS 0- print $ same 1 1- print $ same 0 0- print $ same 1 0+ main = do printLn $ isS 0+ printLn $ isS 1+ printLn $ hasS [0,0,0]+ printLn $ hasS [0,1,2]+ printLn $ isSS 5+ printLn $ isSS 0+ printLn $ same 1 1+ printLn $ same 0 0+ printLn $ same 1 0
+ test/tactics001/Tactics.idr view
@@ -0,0 +1,41 @@+module Tactics++import Language.Reflection.Tactical++import Data.Vect+++%default total++-- Test that basic proofs with new-style tactics work++||| Construct a Refl at some particular type for some particular term+||| @ t the type+||| @ x the term for equality to be reflexive at+refl : (t, x : Raw) -> Raw+refl t x = RApp (RApp (Var (UN "Refl")) t) x++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)++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)++-- Test that side effects in new tactics work++mkDecl : ()+mkDecl = %runTactics (do declareType $ Declare (NS (UN "repUnit") ["Tactics"])+ [Implicit (UN "z") `(Nat)]+ `(Vect ~(Var (UN "z")) ())+ fill `(() : ())+ solve)++repUnit = pure ()
+ test/tactics001/expected view
+ test/tactics001/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --check Tactics.idr+rm -f *.ibc
test/totality001/expected view
@@ -1,3 +1,6 @@-test010.idr:15:1:Main.foo is possibly not total due to: Main.MkBad-test010a.idr:9:1:main.bar is possibly not total due to: main.MkBad-test010b.idr:9:1:main.bar is possibly not total due to: main.MkBad+test010.idr:15:1:+Main.foo is possibly not total due to: Main.MkBad+test010a.idr:9:1:+main.bar is possibly not total due to: main.MkBad+test010b.idr:9:1:+main.bar is possibly not total due to: main.MkBad
test/totality001/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris $@ --check test010.idr-idris $@ --check test010a.idr-idris $@ --check test010b.idr+idris --consolewidth 80 $@ --check test010.idr+idris --consolewidth 80 $@ --check test010a.idr+idris --consolewidth 80 $@ --check test010b.idr rm -f *.ibc
test/totality002/expected view
@@ -1,2 +1,4 @@-test017a.idr:7:1:scg.vtrans is possibly not total due to recursive path scg.vtrans --> scg.vtrans-test017b.idr:4:1:foo.foo is possibly not total due to recursive path foo.foo+test017a.idr:7:1:+scg.vtrans is possibly not total due to recursive path scg.vtrans --> scg.vtrans+test017b.idr:4:1:+foo.foo is possibly not total due to recursive path foo.foo
test/totality002/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris $@ --check test017.idr-idris $@ --check test017a.idr-idris $@ --check test017b.idr+idris --consolewidth 80 $@ --check test017.idr+idris --consolewidth 80 $@ --check test017a.idr+idris --consolewidth 80 $@ --check test017b.idr rm -f *.ibc
test/totality003/expected view
@@ -1,1 +1,2 @@-totality003a.idr:5:1:smaller.qsort is possibly not total due to recursive path smaller.qsort --> smaller.qsort --> smaller.qsort+totality003a.idr:5:1:+smaller.qsort is possibly not total due to recursive path smaller.qsort --> smaller.qsort --> smaller.qsort
test/totality003/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ totality003.idr --check-idris $@ totality003a.idr --check+idris --consolewidth 80 $@ totality003.idr --check+idris --consolewidth 80 $@ totality003a.idr --check rm -f *.ibc
test/totality004/expected view
@@ -1,3 +1,5 @@ [1, 2, 2, 4, 3, 6, 4, 8, 5, 10]-totality004a.idr:13:1:Main.process is possibly not total due to recursive path Main.process --> Main.process --> Main.process-totality004a.idr:24:1:Main.main is possibly not total due to: Main.process+totality004a.idr:13:1:+Main.process is possibly not total due to recursive path Main.process --> Main.process --> Main.process+totality004a.idr:24:1:+Main.main is possibly not total due to: Main.process
test/totality004/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris $@ totality004.idr -o totality004+idris --consolewidth 80 $@ totality004.idr -o totality004 ./totality004-idris $@ --check totality004a.idr +idris --consolewidth 80 $@ --check totality004a.idr rm -f totality004 *.ibc
test/totality004/totality004.idr view
@@ -21,5 +21,5 @@ countStream x = x :: countStream (x + 1) main : IO ()-main = print (take 10 (process doubleInt (countStream 1)))+main = printLn (take 10 (process doubleInt (countStream 1)))
test/totality004/totality004a.idr view
@@ -21,5 +21,5 @@ countStream x = x :: countStream (x + 1) main : IO ()-main = print (take 10 (process doubleInt (countStream 1)))+main = printLn (take 10 (process doubleInt (countStream 1)))
test/totality005/totality005.idr view
@@ -7,4 +7,4 @@ fib = 0 :: zipWithS (+) fib (1 :: fib) partial main : IO ()-main = print (take 15 fib)+main = printLn (take 15 fib)
test/totality006/expected view
@@ -1,2 +1,5 @@-totality006.idr:8:1:Main.prf is not total as there are missing cases+totality006.idr:8:1:+Main.prf is not total as there are missing cases totality006a.idr:11:6:prf' (S _) (S _) Oh is a valid case+totality006b.idr:10:1:+totality006b.blargh is not total as there are missing cases
test/totality006/run view
@@ -1,4 +1,5 @@ #!/usr/bin/env bash-idris $@ totality006.idr --check-idris $@ totality006a.idr --check+idris --consolewidth 80 $@ totality006.idr --check+idris --consolewidth 80 $@ totality006a.idr --check+idris --consolewidth 80 $@ totality006b.idr --check rm -f *.ibc
+ test/totality006/totality006b.idr view
@@ -0,0 +1,14 @@+module totality006b++import Data.So+++-- There are approaches to impossibility checking that break on this+-- 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
test/totality007/expected view
@@ -1,3 +1,4 @@ Type checking ./Totality.idr-Totality.idr:4:1:Totality.foo is not total as there are missing cases+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 = ""+opts = "--consolewidth 80" sourcedir = src modules = Totality
test/totality008/expected view
@@ -1,1 +1,2 @@-totality008.idr:7:1:Main.ElimT is possibly not total due to: Main.c2+totality008.idr:7:1:+Main.ElimT is possibly not total due to: Main.c2
test/totality008/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ totality008.idr --check+idris --consolewidth 80 $@ totality008.idr --check rm -f *.ibc
test/tutorial002/tutorial002.idr view
@@ -34,7 +34,7 @@ main : IO () main = do putStr "Enter a number: " x <- getLine- print (natToBin (fromInteger (cast x)))+ printLn (natToBin (fromInteger (cast x))) ---------- Proofs ----------
test/tutorial003/tutorial003.idr view
@@ -19,7 +19,7 @@ instance Applicative Eval where pure x = MkEval (\e => Just x) - (<$>) (MkEval f) (MkEval g) = MkEval (\x => app (f x) (g x)) where+ (<*>) (MkEval f) (MkEval g) = MkEval (\x => app (f x) (g x)) where app : Maybe (a -> b) -> Maybe a -> Maybe b app (Just fx) (Just gx) = Just (fx gx) app _ _ = Nothing
test/tutorial006/expected view
@@ -1,20 +1,21 @@ tutorial006a.idr:5:23:When elaborating right hand side of vapp: When elaborating argument [95mxs[0m to constructor [91mData.VectType.Vect.::[0m: Can't unify- [94mVect[0m ([95mn[0m [92m+[0m [95mn[0m) [95ma[0m+ [94mVect[0m ([95mn[0m [92m+[0m [95mn[0m) [95ma[0m (Type of vapp [95mxs[0m [95mxs[0m) with- [94mVect[0m ([92mplus[0m [95mn[0m [95mm[0m) [95ma[0m+ [94mVect[0m ([92mplus[0m [95mn[0m [95mm[0m) [95ma[0m (Expected type) Specifically: Can't unify [92mplus[0m [95mn[0m [95mn[0m with [92mplus[0m [95mn[0m [95mm[0m-tutorial006b.idr:10:10:When elaborating right hand side of with block in Main.parity:+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))+ [94mParity[0m ([92mplus[0m ([91mS[0m [95mj[0m) ([91mS[0m [95mj[0m)) (Type of [91meven[0m) with- [94mParity[0m ([91mS[0m ([91mS[0m ([92mplus[0m [95mj[0m [95mj[0m)))+ [94mParity[0m ([91mS[0m ([91mS[0m ([92mplus[0m [95mj[0m [95mj[0m))) (Expected type) Specifically: Can't unify
test/tutorial006/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ tutorial006a.idr --check-idris $@ tutorial006b.idr --check+idris --consolewidth 80 $@ tutorial006a.idr --check+idris --consolewidth 80 $@ tutorial006b.idr --check rm -f *.ibc
test/unique001/expected view
@@ -15,6 +15,7 @@ with [94mInt[0m -> [94mString[0m unique001b.idr:16:7:Borrowed name xs must not be used on RHS-unique001c.idr:49:6:Unique name f is used more than once+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-unique001e.idr:4:11:Constructor Main.:: has a UniqueType, but the data type does not+unique001e.idr:3:10:+Constructor Main.Nil has a UniqueType, but the data type does not
test/unique001/run view
@@ -1,9 +1,9 @@ #!/usr/bin/env bash-idris $@ unique001.idr -o unique001+idris --consolewidth 80 $@ unique001.idr -o unique001 ./unique001-idris $@ unique001a.idr --check-idris $@ unique001b.idr --check-idris $@ unique001c.idr --check-idris $@ unique001d.idr --check-idris $@ unique001e.idr --check+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 rm -f unique001 *.ibc
test/unique001/unique001c.idr view
@@ -11,14 +11,11 @@ ULeaf : UTree UNode : UTree -> Int -> UTree -> UTree -data UPair : UniqueType -> UniqueType -> UniqueType where- MkUPair : {a,b:UniqueType} -> a -> b -> UPair a b- dup : UTree -> UPair UTree UTree-dup ULeaf = MkUPair ULeaf ULeaf-dup (UNode l y r) = let MkUPair l1 l2 = dup l- MkUPair r1 r2 = dup r in- MkUPair (UNode l1 y r1) (UNode l2 y r2)+dup ULeaf = (ULeaf, ULeaf)+dup (UNode l y r) = let (l1, l2) = dup l+ (r1, r2) = dup r in+ (UNode l1 y r1, UNode l2 y r2) data Tree : Type where Leaf : Tree
test/unique002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ unique002.idr --check-idris $@ unique002a.idr --check+idris --consolewidth 80 $@ unique002.idr --check+idris --consolewidth 80 $@ unique002a.idr --check rm -f *.ibc
test/unique003/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ unique003.idr --check+idris --consolewidth 80 $@ unique003.idr --check rm -f *.ibc