idris 0.9.15.1 → 0.9.16
raw patch · 251 files changed
+6886/−3812 lines, 251 filesdep +uniplatedep ~basedep ~deepseqdep ~directorynew-component:exe:idris-cPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: uniplate
Dependency ranges changed: base, deepseq, directory, filepath, haskeline, lens, mtl, transformers
API changes (from Hackage documentation)
- Idris.Apropos: class Apropos a
- Idris.Apropos: defType :: Def -> Type
- Idris.Apropos: isApropos :: Apropos a => Text -> a -> Bool
- Idris.Apropos: textIn :: Text -> Text -> Bool
- Idris.Core.TC: Error :: e -> TC' e a
- Idris.Core.TC: OK :: !a -> TC' e a
- Idris.Core.TC: data TC' e a
- Idris.Core.TC: instance (Eq e, Eq a) => Eq (TC' e a)
- Idris.Core.TC: instance Error e => Alternative (TC' e)
- Idris.Core.TC: instance Error e => Applicative (TC' e)
- Idris.Core.TC: instance Error e => Monad (TC' e)
- Idris.Core.TC: instance Error e => MonadPlus (TC' e)
- Idris.Core.TC: instance Functor (TC' e)
- Idris.Core.TT: instance Error Err
- Idris.Core.TT: type TC = TC' Err
- Idris.DeepSeq: instance NFData ArithTy
- Idris.DeepSeq: instance NFData IntTy
- Idris.DeepSeq: instance NFData NativeTy
- Idris.Help: help :: [([String], CmdArg, String)]
+ Idris.AbsSyntax: getSymbol :: Name -> Idris Name
+ Idris.AbsSyntax: pop_estack :: Idris ()
+ Idris.AbsSyntax: push_estack :: Name -> Idris ()
+ Idris.AbsSyntaxTree: DebugUnify :: PTerm -> PTerm -> Command
+ Idris.AbsSyntaxTree: EState :: [PDecl] -> [Elab' EState ()] -> EState
+ Idris.AbsSyntaxTree: IBCModDocs :: Name -> IBCWrite
+ Idris.AbsSyntaxTree: PAs :: FC -> Name -> PTerm -> PTerm
+ Idris.AbsSyntaxTree: PkgIndex :: FilePath -> Opt
+ Idris.AbsSyntaxTree: ShowPkgs :: Opt
+ Idris.AbsSyntaxTree: SourceFC :: PTactic' t
+ Idris.AbsSyntaxTree: SyntaxRules :: [Syntax] -> SyntaxRules
+ Idris.AbsSyntaxTree: case_decls :: EState -> [PDecl]
+ Idris.AbsSyntaxTree: data EState
+ Idris.AbsSyntaxTree: delayed_elab :: EState -> [Elab' EState ()]
+ Idris.AbsSyntaxTree: elabFC :: ElabInfo -> Maybe FC
+ Idris.AbsSyntaxTree: elab_stack :: IState -> [Name]
+ Idris.AbsSyntaxTree: emptySyntaxRules :: SyntaxRules
+ Idris.AbsSyntaxTree: forall_constraint :: Plicity
+ Idris.AbsSyntaxTree: forall_imp :: Plicity
+ Idris.AbsSyntaxTree: idris_moduledocs :: IState -> Ctxt (Docstring DocTerm)
+ Idris.AbsSyntaxTree: idris_symbols :: IState -> Map Name Name
+ Idris.AbsSyntaxTree: initEState :: EState
+ Idris.AbsSyntaxTree: instance Data ArgOpt
+ Idris.AbsSyntaxTree: instance Data PTerm
+ Idris.AbsSyntaxTree: instance Data Plicity
+ Idris.AbsSyntaxTree: instance Data PunInfo
+ Idris.AbsSyntaxTree: instance Data Static
+ Idris.AbsSyntaxTree: instance Data t => Data (PArg' t)
+ Idris.AbsSyntaxTree: instance Data t => Data (PDo' t)
+ Idris.AbsSyntaxTree: instance Data t => Data (PTactic' t)
+ Idris.AbsSyntaxTree: instance Eq SSymbol
+ Idris.AbsSyntaxTree: instance Typeable ArgOpt
+ Idris.AbsSyntaxTree: instance Typeable PArg'
+ Idris.AbsSyntaxTree: instance Typeable PDo'
+ Idris.AbsSyntaxTree: instance Typeable PTactic'
+ Idris.AbsSyntaxTree: instance Typeable PTerm
+ Idris.AbsSyntaxTree: instance Typeable Plicity
+ Idris.AbsSyntaxTree: instance Typeable PunInfo
+ Idris.AbsSyntaxTree: instance Typeable Static
+ Idris.AbsSyntaxTree: is_scoped :: Plicity -> Maybe ImplicitInfo
+ Idris.AbsSyntaxTree: modDocName :: Name
+ Idris.AbsSyntaxTree: newtype SyntaxRules
+ Idris.AbsSyntaxTree: pscoped :: Plicity -> Maybe ImplicitInfo
+ Idris.AbsSyntaxTree: syntaxRulesList :: SyntaxRules -> [Syntax]
+ Idris.AbsSyntaxTree: syntaxSymbols :: Syntax -> [SSymbol]
+ Idris.AbsSyntaxTree: updateSyntaxRules :: [Syntax] -> SyntaxRules -> SyntaxRules
+ Idris.Apropos: aproposModules :: IState -> Text -> [(String, Docstring DocTerm)]
+ Idris.Core.Binary: instance Binary ImplicitInfo
+ Idris.Core.DeepSeq: instance NFData Accessibility
+ Idris.Core.DeepSeq: instance NFData ArithTy
+ Idris.Core.DeepSeq: instance NFData CaseDefs
+ Idris.Core.DeepSeq: instance NFData CaseInfo
+ Idris.Core.DeepSeq: instance NFData Const
+ Idris.Core.DeepSeq: instance NFData Def
+ Idris.Core.DeepSeq: instance NFData ImplicitInfo
+ Idris.Core.DeepSeq: instance NFData IntTy
+ Idris.Core.DeepSeq: instance NFData MetaInformation
+ Idris.Core.DeepSeq: instance NFData NativeTy
+ Idris.Core.DeepSeq: instance NFData PReason
+ Idris.Core.DeepSeq: instance NFData Totality
+ Idris.Core.DeepSeq: instance NFData Universe
+ Idris.Core.Elaborate: autoArg :: Name -> Elab' aux ()
+ Idris.Core.Elaborate: dotterm :: Elab' aux ()
+ Idris.Core.Elaborate: get_autos :: Elab' aux [(Name, [Name])]
+ Idris.Core.Elaborate: get_dotterm :: Elab' aux [(Name, [Name])]
+ Idris.Core.Elaborate: get_recents :: Elab' aux [Name]
+ Idris.Core.Elaborate: is_guess :: Elab' aux Bool
+ Idris.Core.Evaluate: isTCDict :: Name -> Context -> Bool
+ Idris.Core.ProofState: AutoArg :: Name -> Tactic
+ Idris.Core.ProofState: autos :: ProofState -> [(Name, [Name])]
+ Idris.Core.ProofState: dotted :: ProofState -> [(Name, [Name])]
+ Idris.Core.ProofState: recents :: ProofState -> [Name]
+ Idris.Core.ProofTerm: updateSolvedTerm' :: [(Name, TT Name)] -> TT Name -> (TT Name, Bool)
+ Idris.Core.TT: CantMatch :: t -> Err' t
+ Idris.Core.TT: Error :: Err -> TC a
+ Idris.Core.TT: Impl :: Bool -> ImplicitInfo
+ Idris.Core.TT: OK :: !a -> TC a
+ Idris.Core.TT: WithFnType :: t -> Err' t
+ Idris.Core.TT: bindTC :: TC a -> (a -> TC b) -> TC b
+ Idris.Core.TT: binderImpl :: Binder b -> Maybe ImplicitInfo
+ Idris.Core.TT: data ImplicitInfo
+ Idris.Core.TT: data TC a
+ Idris.Core.TT: instance Alternative TC
+ Idris.Core.TT: instance Applicative TC
+ Idris.Core.TT: instance Data ArithTy
+ Idris.Core.TT: instance Data Const
+ Idris.Core.TT: instance Data ErrorReportPart
+ Idris.Core.TT: instance Data FC
+ Idris.Core.TT: instance Data ImplicitInfo
+ Idris.Core.TT: instance Data IntTy
+ Idris.Core.TT: instance Data Name
+ Idris.Core.TT: instance Data NameType
+ Idris.Core.TT: instance Data NativeTy
+ Idris.Core.TT: instance Data Raw
+ Idris.Core.TT: instance Data SpecialName
+ Idris.Core.TT: instance Data UExp
+ Idris.Core.TT: instance Data Universe
+ Idris.Core.TT: instance Data b => Data (Binder b)
+ Idris.Core.TT: instance Data n => Data (TT n)
+ Idris.Core.TT: instance Data t => Data (Err' t)
+ Idris.Core.TT: instance Eq ImplicitInfo
+ Idris.Core.TT: instance Eq a => Eq (TC a)
+ Idris.Core.TT: instance Functor TC
+ Idris.Core.TT: instance Monad TC
+ Idris.Core.TT: instance MonadPlus TC
+ Idris.Core.TT: instance Ord ImplicitInfo
+ Idris.Core.TT: instance Show ImplicitInfo
+ Idris.Core.TT: instance Typeable ArithTy
+ Idris.Core.TT: instance Typeable Binder
+ Idris.Core.TT: instance Typeable Const
+ Idris.Core.TT: instance Typeable Err'
+ Idris.Core.TT: instance Typeable ErrorReportPart
+ Idris.Core.TT: instance Typeable FC
+ Idris.Core.TT: instance Typeable ImplicitInfo
+ Idris.Core.TT: instance Typeable IntTy
+ Idris.Core.TT: instance Typeable Name
+ Idris.Core.TT: instance Typeable NameType
+ Idris.Core.TT: instance Typeable NativeTy
+ Idris.Core.TT: instance Typeable Raw
+ Idris.Core.TT: instance Typeable SpecialName
+ Idris.Core.TT: instance Typeable TT
+ Idris.Core.TT: instance Typeable UExp
+ Idris.Core.TT: instance Typeable Universe
+ Idris.Core.TT: isTypeConst :: Const -> Bool
+ Idris.Core.TT: refsIn :: TT Name -> [Name]
+ Idris.Core.TT: tcinstance :: ImplicitInfo -> Bool
+ Idris.DeepSeq: instance NFData Codegen
+ Idris.DeepSeq: instance NFData DocTerm
+ Idris.DeepSeq: instance NFData FnInfo
+ Idris.Docs: ModDoc :: [String] -> (Docstring DocTerm) -> Docs
+ Idris.Elab.AsPat: desugarAs :: PTerm -> PTerm -> (PTerm, PTerm)
+ Idris.ElabTerm: ElabCtxt :: Bool -> Bool -> Bool -> Bool -> Bool -> ElabCtxt
+ Idris.ElabTerm: data ElabCtxt
+ Idris.ElabTerm: e_guarded :: ElabCtxt -> Bool
+ Idris.ElabTerm: e_inarg :: ElabCtxt -> Bool
+ Idris.ElabTerm: e_intype :: ElabCtxt -> Bool
+ Idris.ElabTerm: e_nomatching :: ElabCtxt -> Bool
+ Idris.ElabTerm: e_qq :: ElabCtxt -> Bool
+ Idris.ElabTerm: getUnmatchable :: Context -> Name -> [Bool]
+ Idris.ElabTerm: goal_polymorphic :: ElabD Bool
+ Idris.ElabTerm: initElabCtxt :: ElabCtxt
+ Idris.ElabTerm: solveAuto :: IState -> Name -> Bool -> Name -> ElabD ()
+ Idris.ElabTerm: solveAutos :: IState -> Name -> Bool -> ElabD ()
+ Idris.Help: PkgArgs :: CmdArg
+ Idris.IBC: ibc_moduledocs :: IBCFile -> ![(Name, Docstring DocTerm)]
+ Idris.IBC: loadPkgIndex :: String -> Idris ()
+ Idris.IBC: pMDocs :: [(Name, Docstring DocTerm)] -> Idris ()
+ Idris.IBC: writePkgIndex :: FilePath -> Idris ()
+ Idris.Imports: findPkgIndex :: String -> Idris FilePath
+ Idris.Imports: installedPackages :: IO [String]
+ Idris.Imports: pkgIndex :: String -> FilePath
+ Idris.Output: instance MonadException m => MonadException (ExceptT Err m)
+ Idris.ParseExpr: AltsTArg :: TacticArg
+ Idris.ParseExpr: ExprTArg :: TacticArg
+ Idris.ParseExpr: NameTArg :: TacticArg
+ Idris.ParseExpr: StringLitTArg :: TacticArg
+ Idris.ParseExpr: bindsymbol :: (DeltaParsing m, LookAheadParsing m) => [ArgOpt] -> Static -> t -> m Plicity
+ Idris.ParseExpr: constants :: [(String, Const)]
+ Idris.ParseExpr: constraintList1 :: SyntaxInfo -> IdrisParser [(Name, PTerm)]
+ Idris.ParseExpr: data TacticArg
+ Idris.ParseExpr: tactics :: [([String], Maybe TacticArg, SyntaxInfo -> IdrisParser PTactic)]
+ Idris.REPL: getPkgIndex :: Opt -> Maybe FilePath
+ Idris.REPLParser: allHelp :: [([String], CmdArg, String)]
+ Idris.REPLParser: help :: [([String], CmdArg, String)]
+ Pkg.Package: installIdx :: String -> IO ()
+ Pkg.Package: rmIdx :: String -> IO ()
- IRTS.System: getIncFlags :: IO [Char]
+ IRTS.System: getIncFlags :: IO [[Char]]
- IRTS.System: getLibFlags :: IO [Char]
+ IRTS.System: getLibFlags :: IO [[Char]]
- Idris.AbsSyntax: addImported :: FilePath -> Idris ()
+ Idris.AbsSyntax: addImported :: Bool -> FilePath -> Idris ()
- Idris.AbsSyntax: getImported :: Idris [FilePath]
+ Idris.AbsSyntax: getImported :: Idris [(FilePath, Bool)]
- Idris.AbsSyntaxTree: Apropos :: String -> Command
+ Idris.AbsSyntaxTree: Apropos :: [String] -> String -> Command
- Idris.AbsSyntaxTree: EInfo :: [(Name, PTerm)] -> Ctxt [Name] -> (Name -> Name) -> Maybe [String] -> (ElabWhat -> ElabInfo -> PDecl -> Idris ()) -> ElabInfo
+ Idris.AbsSyntaxTree: EInfo :: [(Name, PTerm)] -> Ctxt [Name] -> (Name -> Name) -> Maybe [String] -> Maybe FC -> (ElabWhat -> ElabInfo -> PDecl -> Idris ()) -> ElabInfo
- Idris.AbsSyntaxTree: IBCImport :: FilePath -> IBCWrite
+ Idris.AbsSyntaxTree: IBCImport :: (Bool, FilePath) -> IBCWrite
- 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 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)] -> [Syntax] -> [String] -> [FilePath] -> [(Name, (Int, PrimFn))] -> [(Codegen, FilePath)] -> [(Codegen, String)] -> [(Codegen, String)] -> [(Codegen, String)] -> [FilePath] -> [(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] -> 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 -> Maybe (Map Name [Name]) -> Maybe (Map Name [Name]) -> [Name] -> [Name] -> Map Name Name -> IState
- Idris.AbsSyntaxTree: Imp :: [ArgOpt] -> Static -> Bool -> Plicity
+ Idris.AbsSyntaxTree: Imp :: [ArgOpt] -> Static -> Bool -> Maybe ImplicitInfo -> Plicity
- Idris.AbsSyntaxTree: PClass :: (Docstring (Either Err PTerm)) -> SyntaxInfo -> FC -> [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))] -> [PDecl' t] -> PDecl' t
- Idris.AbsSyntaxTree: PInstance :: SyntaxInfo -> FC -> [t] -> Name -> [t] -> t -> (Maybe Name) -> [PDecl' t] -> PDecl' t
+ Idris.AbsSyntaxTree: PInstance :: SyntaxInfo -> FC -> [(Name, t)] -> Name -> [t] -> t -> (Maybe Name) -> [PDecl' t] -> PDecl' t
- Idris.AbsSyntaxTree: PLam :: Name -> PTerm -> PTerm -> PTerm
+ Idris.AbsSyntaxTree: PLam :: FC -> Name -> PTerm -> PTerm -> PTerm
- Idris.AbsSyntaxTree: PLet :: Name -> PTerm -> PTerm -> PTerm -> PTerm
+ Idris.AbsSyntaxTree: PLet :: FC -> Name -> PTerm -> PTerm -> PTerm -> PTerm
- Idris.AbsSyntaxTree: Search :: PTerm -> Command
+ Idris.AbsSyntaxTree: Search :: [String] -> PTerm -> Command
- Idris.AbsSyntaxTree: eqOpts :: [a]
+ Idris.AbsSyntaxTree: eqOpts :: [t]
- Idris.AbsSyntaxTree: idris_imported :: IState -> [FilePath]
+ Idris.AbsSyntaxTree: idris_imported :: IState -> [(FilePath, Bool)]
- Idris.AbsSyntaxTree: inferOpts :: [a]
+ Idris.AbsSyntaxTree: inferOpts :: [t]
- Idris.AbsSyntaxTree: syntax_rules :: IState -> [Syntax]
+ Idris.AbsSyntaxTree: syntax_rules :: IState -> SyntaxRules
- Idris.AbsSyntaxTree: type ElabD a = Elab' [PDecl] a
+ Idris.AbsSyntaxTree: type ElabD a = Elab' EState a
- Idris.AbsSyntaxTree: type Idris = StateT IState (ErrorT Err IO)
+ Idris.AbsSyntaxTree: type Idris = StateT IState (ExceptT Err IO)
- Idris.Core.CaseTree: simpleCase :: Bool -> Bool -> Bool -> Phase -> FC -> [Int] -> [Type] -> [([Name], Term, Term)] -> ErasureInfo -> TC CaseDef
+ Idris.Core.CaseTree: simpleCase :: Bool -> SC -> Bool -> Phase -> FC -> [Int] -> [Type] -> [([Name], Term, Term)] -> ErasureInfo -> TC CaseDef
- Idris.Core.Elaborate: arg :: Name -> Name -> Elab' aux ()
+ Idris.Core.Elaborate: arg :: Name -> Maybe ImplicitInfo -> Name -> Elab' aux ()
- Idris.Core.Elaborate: forall :: Name -> Raw -> Elab' aux ()
+ Idris.Core.Elaborate: forall :: Name -> Maybe ImplicitInfo -> Raw -> Elab' aux ()
- Idris.Core.Elaborate: prunStateT :: Int -> Bool -> [a] -> StateT (ElabState t) (TC' Err) t1 -> ElabState t -> TC' Err ((t1, Int, Fails), ElabState t)
+ Idris.Core.Elaborate: prunStateT :: Int -> Bool -> [a] -> StateT (ElabState t) TC t1 -> ElabState t -> TC ((t1, Int, Fails), ElabState t)
- Idris.Core.Evaluate: addCasedef :: Name -> ErasureInfo -> CaseInfo -> Bool -> Bool -> Bool -> Bool -> [Type] -> [Int] -> [Either Term (Term, Term)] -> [([Name], Term, Term)] -> [([Name], Term, Term)] -> [([Name], Term, Term)] -> [([Name], Term, Term)] -> Type -> Context -> Context
+ Idris.Core.Evaluate: addCasedef :: Name -> ErasureInfo -> CaseInfo -> Bool -> SC -> Bool -> Bool -> [Type] -> [Int] -> [Either Term (Term, Term)] -> [([Name], Term, Term)] -> [([Name], Term, Term)] -> [([Name], Term, Term)] -> [([Name], Term, Term)] -> Type -> Context -> Context
- Idris.Core.Evaluate: convEq :: Context -> [Name] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool
+ Idris.Core.Evaluate: convEq :: Context -> [Name] -> TT Name -> TT Name -> StateT UCs TC Bool
- Idris.Core.Evaluate: convEq' :: Context -> [Name] -> TT Name -> TT Name -> TC' Err Bool
+ Idris.Core.Evaluate: convEq' :: Context -> [Name] -> TT Name -> TT Name -> TC Bool
- Idris.Core.ProofState: Forall :: Name -> Raw -> Tactic
+ Idris.Core.ProofState: Forall :: Name -> (Maybe ImplicitInfo) -> Raw -> Tactic
- Idris.Core.ProofState: PS :: Name -> [Name] -> [Name] -> Int -> ProofTerm -> Type -> [Name] -> (Name, [(Name, Term)]) -> [(Name, Term)] -> Maybe (Name, Term) -> Fails -> [Name] -> [Name] -> [Name] -> Maybe ProofState -> Context -> String -> Bool -> Bool -> [FailContext] -> ProofState
+ Idris.Core.ProofState: PS :: Name -> [Name] -> [Name] -> Int -> ProofTerm -> Type -> [Name] -> (Name, [(Name, Term)]) -> [(Name, Term)] -> [(Name, [Name])] -> Maybe (Name, Term) -> Fails -> [Name] -> [Name] -> [Name] -> [(Name, [Name])] -> Maybe ProofState -> Context -> String -> Bool -> Bool -> [Name] -> [FailContext] -> ProofState
- Idris.Core.TT: Pi :: !b -> !b -> Binder b
+ Idris.Core.TT: Pi :: Maybe ImplicitInfo -> !b -> !b -> Binder b
- Idris.Core.TT: prettyEnv :: (Eq a1, Show a1, Pretty a1 a, Pretty NameType a, Pretty Const a) => [(a1, Binder (TT a1))] -> TT a1 -> Doc a
+ Idris.Core.TT: prettyEnv :: (Pretty Const a, Pretty NameType a, Pretty a1 a, Show a1, Eq a1) => [(a1, Binder (TT a1))] -> TT a1 -> Doc a
- Idris.Core.TT: showEnv' :: (Eq a, Show a) => [(a, Binder (TT a))] -> TT a -> Bool -> [Char]
+ Idris.Core.TT: showEnv' :: (Show a, Eq a) => [(a, Binder (TT a))] -> TT a -> Bool -> [Char]
- Idris.Core.TT: showEnvDbg :: (Eq a, Show a) => [(a, Binder (TT a))] -> TT a -> [Char]
+ Idris.Core.TT: showEnvDbg :: (Show a, Eq a) => [(a, Binder (TT a))] -> TT a -> [Char]
- Idris.Core.Unify: type Fails = [(TT Name, TT Name, Env, Err, [FailContext], FailAt)]
+ Idris.Core.Unify: type Fails = [(TT Name, TT Name, Bool, Env, Err, [FailContext], FailAt)]
- Idris.Elab.Class: elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> FC -> [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))] -> [PDecl] -> Idris ()
- Idris.Elab.Instance: elabInstance :: ElabInfo -> SyntaxInfo -> ElabWhat -> FC -> [PTerm] -> Name -> [PTerm] -> PTerm -> Maybe Name -> [PDecl] -> Idris ()
+ Idris.Elab.Instance: elabInstance :: ElabInfo -> SyntaxInfo -> ElabWhat -> FC -> [(Name, PTerm)] -> Name -> [PTerm] -> PTerm -> Maybe Name -> [PDecl] -> Idris ()
- Idris.Elab.Utils: checkAddDef :: Bool -> Bool -> FC -> [(Name, (Int, Maybe Name, TT Name))] -> StateT IState (ErrorT Err IO) [(Name, (Int, Maybe Name, Term))]
+ 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: checkDef :: FC -> [(Name, (Int, Maybe Name, TT Name))] -> StateT IState (ErrorT Err IO) [(Name, (Int, Maybe Name, Term))]
+ Idris.Elab.Utils: checkDef :: FC -> [(Name, (Int, Maybe Name, TT Name))] -> StateT IState (ExceptT Err IO) [(Name, (Int, Maybe Name, Term))]
- Idris.Elab.Utils: paramNames :: Eq a => [TT a] -> [a] -> [Int] -> [a]
+ Idris.Elab.Utils: paramNames :: Eq t => [TT t] -> [t] -> [Int] -> [t]
- Idris.Elab.Utils: recheckC :: FC -> Env -> TT Name -> StateT IState (ErrorT Err IO) (Term, Type)
+ Idris.Elab.Utils: recheckC :: FC -> Env -> TT Name -> StateT IState (ExceptT Err IO) (Term, Type)
- Idris.Elab.Utils: recheckC_borrowing :: Bool -> [Name] -> FC -> Env -> TT Name -> StateT IState (ErrorT Err IO) (Term, Type)
+ Idris.Elab.Utils: recheckC_borrowing :: Bool -> [Name] -> FC -> Env -> TT Name -> StateT IState (ExceptT Err IO) (Term, Type)
- Idris.ElabDecls: elabDecl' :: ElabWhat -> ElabInfo -> PDecl' PTerm -> StateT IState (ErrorT Err IO) ()
+ Idris.ElabDecls: elabDecl' :: ElabWhat -> ElabInfo -> PDecl' PTerm -> StateT IState (ExceptT Err IO) ()
- Idris.ElabTerm: proofSearch' :: IState -> Bool -> Int -> Bool -> Maybe Name -> Name -> [Name] -> StateT (ElabState [PDecl]) TC ()
+ Idris.ElabTerm: proofSearch' :: IState -> Bool -> Bool -> Int -> Bool -> Maybe Name -> Name -> [Name] -> StateT (ElabState EState) TC ()
- Idris.ElabTerm: resTC' :: (Eq a, Num a) => [TT Name] -> Bool -> a -> Term -> Name -> IState -> StateT (ElabState [PDecl]) TC ()
+ Idris.ElabTerm: resTC' :: (Num a, Eq a) => [TT Name] -> Bool -> a -> Term -> Name -> IState -> StateT (ElabState EState) TC ()
- Idris.ElabTerm: runTac :: Bool -> IState -> Name -> PTactic -> ElabD ()
+ Idris.ElabTerm: runTac :: Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
- Idris.IBC: IBCFile :: Word8 -> FilePath -> [Name] -> [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, (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) -> IBCFile
- Idris.IBC: ibc_access :: IBCFile -> [(Name, Accessibility)]
+ Idris.IBC: ibc_access :: IBCFile -> ![(Name, Accessibility)]
- Idris.IBC: ibc_cg :: IBCFile -> [(Name, CGInfo)]
+ Idris.IBC: ibc_cg :: IBCFile -> ![(Name, CGInfo)]
- Idris.IBC: ibc_cgflags :: IBCFile -> [(Codegen, String)]
+ Idris.IBC: ibc_cgflags :: IBCFile -> ![(Codegen, String)]
- Idris.IBC: ibc_classes :: IBCFile -> [(Name, ClassInfo)]
+ Idris.IBC: ibc_classes :: IBCFile -> ![(Name, ClassInfo)]
- Idris.IBC: ibc_coercions :: IBCFile -> [Name]
+ Idris.IBC: ibc_coercions :: IBCFile -> ![Name]
- Idris.IBC: ibc_datatypes :: IBCFile -> [(Name, TypeInfo)]
+ Idris.IBC: ibc_datatypes :: IBCFile -> ![(Name, TypeInfo)]
- Idris.IBC: ibc_defs :: IBCFile -> [(Name, Def)]
+ Idris.IBC: ibc_defs :: IBCFile -> ![(Name, Def)]
- Idris.IBC: ibc_docstrings :: IBCFile -> [(Name, (Docstring DocTerm, [(Name, Docstring DocTerm)]))]
+ Idris.IBC: ibc_docstrings :: IBCFile -> ![(Name, (Docstring DocTerm, [(Name, Docstring DocTerm)]))]
- Idris.IBC: ibc_dsls :: IBCFile -> [(Name, DSL)]
+ Idris.IBC: ibc_dsls :: IBCFile -> ![(Name, DSL)]
- Idris.IBC: ibc_dynamic_libs :: IBCFile -> [String]
+ Idris.IBC: ibc_dynamic_libs :: IBCFile -> ![String]
- Idris.IBC: ibc_errRev :: IBCFile -> [(Term, Term)]
+ Idris.IBC: ibc_errRev :: IBCFile -> ![(Term, Term)]
- Idris.IBC: ibc_errorhandlers :: IBCFile -> [Name]
+ Idris.IBC: ibc_errorhandlers :: IBCFile -> ![Name]
- Idris.IBC: ibc_fixes :: IBCFile -> [FixDecl]
+ Idris.IBC: ibc_fixes :: IBCFile -> ![FixDecl]
- Idris.IBC: ibc_flags :: IBCFile -> [(Name, [FnOpt])]
+ Idris.IBC: ibc_flags :: IBCFile -> ![(Name, [FnOpt])]
- Idris.IBC: ibc_fninfo :: IBCFile -> [(Name, FnInfo)]
+ Idris.IBC: ibc_fninfo :: IBCFile -> ![(Name, FnInfo)]
- Idris.IBC: ibc_function_errorhandlers :: IBCFile -> [(Name, Name, Name)]
+ Idris.IBC: ibc_function_errorhandlers :: IBCFile -> ![(Name, Name, Name)]
- Idris.IBC: ibc_hdrs :: IBCFile -> [(Codegen, String)]
+ Idris.IBC: ibc_hdrs :: IBCFile -> ![(Codegen, String)]
- Idris.IBC: ibc_implicits :: IBCFile -> [(Name, [PArg])]
+ Idris.IBC: ibc_implicits :: IBCFile -> ![(Name, [PArg])]
- Idris.IBC: ibc_importdirs :: IBCFile -> [FilePath]
+ Idris.IBC: ibc_importdirs :: IBCFile -> ![FilePath]
- Idris.IBC: ibc_imports :: IBCFile -> [FilePath]
+ Idris.IBC: ibc_imports :: IBCFile -> ![(Bool, FilePath)]
- Idris.IBC: ibc_instances :: IBCFile -> [(Bool, Name, Name)]
+ Idris.IBC: ibc_instances :: IBCFile -> ![(Bool, Name, Name)]
- Idris.IBC: ibc_keywords :: IBCFile -> [String]
+ Idris.IBC: ibc_keywords :: IBCFile -> ![String]
- Idris.IBC: ibc_libs :: IBCFile -> [(Codegen, String)]
+ Idris.IBC: ibc_libs :: IBCFile -> ![(Codegen, String)]
- Idris.IBC: ibc_lineapps :: IBCFile -> [(FilePath, Int, PTerm)]
+ Idris.IBC: ibc_lineapps :: IBCFile -> ![(FilePath, Int, PTerm)]
- Idris.IBC: ibc_metainformation :: IBCFile -> [(Name, MetaInformation)]
+ Idris.IBC: ibc_metainformation :: IBCFile -> ![(Name, MetaInformation)]
- Idris.IBC: ibc_metavars :: IBCFile -> [(Name, (Maybe Name, Int, Bool))]
+ Idris.IBC: ibc_metavars :: IBCFile -> ![(Name, (Maybe Name, Int, Bool))]
- Idris.IBC: ibc_namehints :: IBCFile -> [(Name, Name)]
+ Idris.IBC: ibc_namehints :: IBCFile -> ![(Name, Name)]
- Idris.IBC: ibc_objs :: IBCFile -> [(Codegen, FilePath)]
+ Idris.IBC: ibc_objs :: IBCFile -> ![(Codegen, FilePath)]
- Idris.IBC: ibc_optimise :: IBCFile -> [(Name, OptInfo)]
+ Idris.IBC: ibc_optimise :: IBCFile -> ![(Name, OptInfo)]
- Idris.IBC: ibc_parsedSpan :: IBCFile -> Maybe FC
+ Idris.IBC: ibc_parsedSpan :: IBCFile -> !(Maybe FC)
- Idris.IBC: ibc_patdefs :: IBCFile -> [(Name, ([([Name], Term, Term)], [PTerm]))]
+ Idris.IBC: ibc_patdefs :: IBCFile -> ![(Name, ([([Name], Term, Term)], [PTerm]))]
- Idris.IBC: ibc_postulates :: IBCFile -> [Name]
+ Idris.IBC: ibc_postulates :: IBCFile -> ![Name]
- Idris.IBC: ibc_statics :: IBCFile -> [(Name, [Bool])]
+ Idris.IBC: ibc_statics :: IBCFile -> ![(Name, [Bool])]
- Idris.IBC: ibc_syntax :: IBCFile -> [Syntax]
+ Idris.IBC: ibc_syntax :: IBCFile -> ![Syntax]
- Idris.IBC: ibc_total :: IBCFile -> [(Name, Totality)]
+ Idris.IBC: ibc_total :: IBCFile -> ![(Name, Totality)]
- Idris.IBC: ibc_totcheckfail :: IBCFile -> [(FC, String)]
+ Idris.IBC: ibc_totcheckfail :: IBCFile -> ![(FC, String)]
- Idris.IBC: ibc_transforms :: IBCFile -> [(Name, (Term, Term))]
+ Idris.IBC: ibc_transforms :: IBCFile -> ![(Name, (Term, Term))]
- Idris.IBC: loadIBC :: FilePath -> Idris ()
+ Idris.IBC: loadIBC :: Bool -> FilePath -> Idris ()
- Idris.IBC: pAccess :: [(Name, Accessibility)] -> Idris ()
+ Idris.IBC: pAccess :: Bool -> [(Name, Accessibility)] -> Idris ()
- Idris.IBC: pDefs :: [Name] -> [(Name, Def)] -> Idris ()
+ Idris.IBC: pDefs :: Bool -> [Name] -> [(Name, Def)] -> Idris ()
- Idris.IBC: pImports :: [FilePath] -> Idris ()
+ Idris.IBC: pImports :: [(Bool, FilePath)] -> Idris ()
- Idris.IBC: process :: IBCFile -> FilePath -> Idris ()
+ Idris.IBC: process :: Bool -> IBCFile -> FilePath -> Idris ()
- Idris.IBC: symbols :: IBCFile -> [Name]
+ Idris.IBC: symbols :: IBCFile -> ![Name]
- Idris.ParseExpr: constraintList :: SyntaxInfo -> IdrisParser [PTerm]
+ Idris.ParseExpr: constraintList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]
- Idris.ParseExpr: extension :: SyntaxInfo -> Syntax -> IdrisParser PTerm
+ Idris.ParseExpr: extension :: SyntaxInfo -> [Maybe (Name, SynMatch)] -> [Syntax] -> IdrisParser PTerm
- Idris.Parser: import_ :: IdrisParser (String, Maybe String, FC)
+ Idris.Parser: import_ :: IdrisParser (Bool, String, Maybe String, FC)
- Idris.Parser: loadFromIFile :: IFileType -> Maybe Int -> Idris ()
+ Idris.Parser: loadFromIFile :: Bool -> IFileType -> Maybe Int -> Idris ()
- Idris.Parser: loadModule :: FilePath -> Idris String
+ Idris.Parser: loadModule :: FilePath -> Idris (Maybe String)
- Idris.Parser: moduleHeader :: IdrisParser [String]
+ Idris.Parser: moduleHeader :: IdrisParser (Maybe (Docstring ()), [String])
- Idris.Parser: parseImports :: FilePath -> String -> Idris ([String], [(String, Maybe String, FC)], Maybe Delta)
+ Idris.Parser: parseImports :: FilePath -> String -> Idris (Maybe (Docstring ()), [String], [(Bool, String, Maybe String, FC)], Maybe Delta)
- Idris.ProofSearch: proofSearch :: Bool -> Bool -> Int -> (PTerm -> ElabD ()) -> Maybe Name -> Name -> [Name] -> IState -> ElabD ()
+ Idris.ProofSearch: proofSearch :: Bool -> Bool -> Bool -> Bool -> Int -> (PTerm -> ElabD ()) -> Maybe Name -> Name -> [Name] -> IState -> ElabD ()
- Idris.Prover: assumptionNames :: ElabState [PDecl] -> [String]
+ Idris.Prover: assumptionNames :: ElabState EState -> [String]
- Idris.Prover: elabStep :: ElabState [PDecl] -> ElabD a -> Idris (a, ElabState [PDecl])
+ Idris.Prover: elabStep :: ElabState EState -> ElabD a -> Idris (a, ElabState EState)
- Idris.Prover: lifte :: ElabState [PDecl] -> ElabD a -> Idris a
+ Idris.Prover: lifte :: ElabState EState -> ElabD a -> Idris a
- Idris.Prover: ploop :: Name -> Bool -> String -> [String] -> ElabState [PDecl] -> Maybe History -> Idris (Term, [String])
+ Idris.Prover: ploop :: Name -> Bool -> String -> [String] -> ElabState EState -> Maybe History -> Idris (Term, [String])
- Idris.Prover: proverSettings :: ElabState [PDecl] -> Settings Idris
+ Idris.Prover: proverSettings :: ElabState EState -> Settings Idris
- Idris.Prover: receiveInput :: Handle -> ElabState [PDecl] -> Idris (Maybe String)
+ Idris.Prover: receiveInput :: Handle -> ElabState EState -> Idris (Maybe String)
- Idris.REPL: loadInputs :: [FilePath] -> Maybe Int -> Idris ()
+ Idris.REPL: loadInputs :: [FilePath] -> Maybe Int -> Idris [FilePath]
- Idris.REPL: processInput :: String -> IState -> [FilePath] -> Idris (Maybe [FilePath])
+ Idris.REPL: processInput :: String -> IState -> [FilePath] -> FilePath -> Idris (Maybe [FilePath])
- Idris.REPL: repl :: IState -> [FilePath] -> InputT Idris ()
+ Idris.REPL: repl :: IState -> [FilePath] -> FilePath -> InputT Idris ()
- Idris.TypeSearch: searchByType :: PTerm -> Idris ()
+ Idris.TypeSearch: searchByType :: [String] -> PTerm -> Idris ()
Files
- Makefile +4/−0
- codegen/idris-c/Main.hs +44/−0
- config.mk +1/−1
- idris.cabal +73/−20
- libs/base/Control/Arrow.idr +66/−0
- libs/base/Control/Isomorphism.idr +1/−0
- libs/base/Control/Monad/Reader.idr +4/−0
- libs/base/Control/Monad/State.idr +5/−0
- libs/base/Control/Monad/Trans.idr +4/−0
- libs/base/Control/Monad/Writer.idr +5/−0
- libs/base/Data/Bits.idr +2/−0
- libs/base/Data/BoundedList.idr +2/−0
- libs/base/Data/Buffer.idr +2/−0
- libs/base/Data/Fin.idr +187/−0
- libs/base/Data/Fun.idr +2/−0
- libs/base/Data/HVect.idr +1/−0
- libs/base/Data/Hash.idr +2/−0
- libs/base/Data/Matrix.idr +256/−0
- libs/base/Data/So.idr +25/−0
- libs/base/Data/Vect.idr +1/−0
- libs/base/Data/Vect/Quantifiers.idr +2/−0
- libs/base/Data/VectType.idr +598/−0
- libs/base/Debug/Error.idr +20/−0
- libs/base/Decidable/Decidable.idr +4/−3
- libs/base/Decidable/Order.idr +3/−0
- libs/base/Language/Reflection.idr +0/−479
- libs/base/Language/Reflection/Errors.idr +0/−45
- libs/base/Language/Reflection/Utils.idr +9/−3
- libs/base/Network/Socket.idr +2/−2
- libs/base/System.idr +0/−2
- libs/base/base.ipkg +7/−5
- libs/effects/Effect/Default.idr +2/−0
- libs/effects/Effect/File.idr +14/−0
- libs/effects/Effect/Memory.idr +4/−2
- libs/effects/Effect/Random.idr +3/−1
- libs/effects/Effects.idr +2/−2
- libs/prelude/Builtins.idr +21/−20
- libs/prelude/Decidable/Equality.idr +7/−51
- libs/prelude/IO.idr +1/−0
- libs/prelude/Language/Reflection.idr +496/−0
- libs/prelude/Language/Reflection/Errors.idr +48/−0
- libs/prelude/Prelude.idr +37/−66
- libs/prelude/Prelude/Algebra.idr +23/−16
- libs/prelude/Prelude/Applicative.idr +13/−0
- libs/prelude/Prelude/Basics.idr +1/−1
- libs/prelude/Prelude/Bits.idr +9/−3
- libs/prelude/Prelude/Bool.idr +0/−15
- libs/prelude/Prelude/Classes.idr +1/−1
- libs/prelude/Prelude/Either.idr +4/−6
- libs/prelude/Prelude/Fin.idr +0/−152
- libs/prelude/Prelude/Foldable.idr +1/−0
- libs/prelude/Prelude/Functor.idr +6/−0
- libs/prelude/Prelude/List.idr +9/−4
- libs/prelude/Prelude/Maybe.idr +7/−0
- libs/prelude/Prelude/Monad.idr +10/−0
- libs/prelude/Prelude/Nat.idr +1/−0
- libs/prelude/Prelude/Stream.idr +14/−9
- libs/prelude/Prelude/Strings.idr +14/−6
- libs/prelude/Prelude/Traversable.idr +4/−0
- libs/prelude/Prelude/Uninhabited.idr +3/−0
- libs/prelude/Prelude/Vect.idr +0/−548
- libs/prelude/prelude.ipkg +4/−2
- main/Main.hs +9/−3
- rts/Makefile +9/−0
- rts/idris_bitstring.c +156/−86
- rts/idris_bitstring.h +10/−0
- rts/idris_gc.c +21/−8
- rts/idris_gmp.c +46/−15
- rts/idris_gmp.h +3/−0
- rts/idris_main.c +7/−2
- rts/idris_rts.c +244/−58
- rts/idris_rts.h +61/−33
- rts/idris_stats.c +11/−11
- rts/idris_stats.h +10/−8
- src/IRTS/CodegenC.hs +53/−35
- src/IRTS/CodegenJavaScript.hs +11/−4
- src/IRTS/Compiler.hs +18/−17
- src/IRTS/System.hs +9/−9
- src/Idris/AbsSyntax.hs +169/−109
- src/Idris/AbsSyntaxTree.hs +232/−134
- src/Idris/Apropos.hs +19/−5
- src/Idris/CaseSplit.hs +5/−3
- src/Idris/Chaser.hs +3/−3
- src/Idris/CmdOptions.hs +11/−10
- src/Idris/Colours.hs +12/−1
- src/Idris/Completion.hs +28/−43
- src/Idris/Core/Binary.hs +20/−5
- src/Idris/Core/CaseTree.hs +34/−40
- src/Idris/Core/Constraints.hs +3/−3
- src/Idris/Core/DeepSeq.hs +107/−2
- src/Idris/Core/Elaborate.hs +85/−28
- src/Idris/Core/Evaluate.hs +68/−29
- src/Idris/Core/Execute.hs +13/−5
- src/Idris/Core/ProofState.hs +151/−119
- src/Idris/Core/ProofTerm.hs +8/−6
- src/Idris/Core/TC.hs +0/−37
- src/Idris/Core/TT.hs +128/−67
- src/Idris/Core/Typecheck.hs +31/−29
- src/Idris/Core/Unify.hs +111/−77
- src/Idris/Coverage.hs +27/−28
- src/Idris/DSL.hs +19/−19
- src/Idris/DeepSeq.hs +38/−21
- src/Idris/Delaborate.hs +76/−24
- src/Idris/Docs.hs +14/−0
- src/Idris/Docstrings.hs +1/−1
- src/Idris/Elab/AsPat.hs +48/−0
- src/Idris/Elab/Class.hs +12/−11
- src/Idris/Elab/Clause.hs +50/−23
- src/Idris/Elab/Data.hs +19/−10
- src/Idris/Elab/Instance.hs +15/−12
- src/Idris/Elab/Record.hs +4/−4
- src/Idris/Elab/Transform.hs +16/−4
- src/Idris/Elab/Type.hs +4/−4
- src/Idris/Elab/Utils.hs +15/−11
- src/Idris/Elab/Value.hs +2/−2
- src/Idris/ElabDecls.hs +8/−8
- src/Idris/ElabQuasiquote.hs +4/−4
- src/Idris/ElabTerm.hs +387/−197
- src/Idris/Erasure.hs +2/−2
- src/Idris/Error.hs +7/−4
- src/Idris/Help.hs +5/−49
- src/Idris/IBC.hs +236/−193
- src/Idris/IdeSlave.hs +4/−4
- src/Idris/IdrisDoc.hs +45/−25
- src/Idris/Imports.hs +28/−0
- src/Idris/Interactive.hs +6/−6
- src/Idris/Output.hs +9/−4
- src/Idris/ParseExpr.hs +196/−164
- src/Idris/ParseHelpers.hs +9/−2
- src/Idris/Parser.hs +68/−44
- src/Idris/PartialEval.hs +14/−12
- src/Idris/Primitives.hs +2/−2
- src/Idris/ProofSearch.hs +45/−9
- src/Idris/Prover.hs +25/−18
- src/Idris/REPL.hs +91/−58
- src/Idris/REPLParser.hs +183/−130
- src/Idris/Transforms.hs +5/−0
- src/Idris/TypeSearch.hs +35/−22
- src/Pkg/PParser.hs +7/−0
- src/Pkg/Package.hs +30/−20
- test/Makefile +3/−4
- test/basic001/basic001a.idr +2/−0
- test/basic001/reg005.idr +5/−1
- test/basic005/test019.lidr +2/−0
- test/basic006/expected +1/−7
- test/basic006/test020.idr +2/−0
- test/basic006/test020a.idr +2/−0
- test/basic009/Multiple.idr +2/−2
- test/basic012/basic012.idr +62/−0
- test/basic012/expected +2/−0
- test/basic012/run +4/−0
- test/delab001/delab001.idr +16/−0
- test/delab001/expected +13/−0
- test/delab001/input +4/−0
- test/delab001/run +3/−0
- test/dsl001/test001.idr +3/−0
- test/dsl002/Resimp.idr +3/−0
- test/dsl003/DSLPi.idr +3/−0
- test/effects001/test021.idr +1/−0
- test/effects001/test021a.idr +1/−0
- test/effects002/test025.idr +1/−0
- test/effects003/VectMissing.idr +14/−0
- test/effects003/expected +41/−0
- test/effects003/hangman.idr +223/−0
- test/effects003/input +10/−0
- test/effects003/run +4/−0
- test/error003/ErrorReflection.idr +1/−0
- test/error003/expected +2/−2
- test/error005/error005.idr +20/−0
- test/error005/expected +12/−0
- test/error005/run +3/−0
- test/idrisdoc009/Test.idr +45/−0
- test/idrisdoc009/expected +29/−0
- test/idrisdoc009/input +2/−0
- test/idrisdoc009/run +3/−0
- test/interactive001/input +6/−6
- test/interactive001/test032.idr +1/−0
- test/interactive002/input +10/−10
- test/interactive002/interactive002.idr +1/−0
- test/interactive003/input +4/−4
- test/interactive003/interactive003.idr +2/−0
- test/interactive004/input +2/−2
- test/interactive004/interactive004.idr +2/−0
- test/io003/test018a.idr +1/−0
- test/primitives003/test038.idr +3/−0
- test/proof001/test029.idr +6/−2
- test/proof002/Reflect.idr +1/−0
- test/proof002/expected +1/−1
- test/proof003/test015.idr +3/−3
- test/quasiquote001/expected +2/−2
- test/quasiquote002/GoalQQuote.idr +1/−0
- test/quasiquote003/NoInfer.idr +1/−0
- test/quasiquote003/expected +1/−1
- test/records001/test011.idr +2/−0
- test/reg002/reg002.idr +0/−31
- test/reg002/reg012.idr +33/−0
- test/reg002/run +3/−3
- test/reg005/reg005.idr +12/−0
- test/reg005/reg032.idr +0/−10
- test/reg005/run +1/−1
- test/reg009/reg009.lidr +3/−0
- test/reg010/expected +2/−11
- test/reg011/reg011.idr +2/−0
- test/reg012/reg012.lidr +3/−1
- test/reg014/reg014.idr +2/−0
- test/reg018/expected +2/−2
- test/reg018/reg018c.idr +2/−0
- test/reg018/reg018d.idr +3/−0
- test/reg020/reg020.idr +2/−0
- test/reg023/expected +0/−6
- test/reg025/reg025.idr +7/−5
- test/reg026/reg026.idr +2/−0
- test/reg033/reg033.idr +2/−0
- test/reg034/expected +2/−22
- test/reg035/expected +1/−1
- test/reg035/reg035a.lidr +2/−0
- test/reg035/reg035b.idr +1/−0
- test/reg050/expected +5/−4
- test/reg054/expected +10/−0
- test/reg054/reg054.idr +39/−0
- test/reg054/run +2/−0
- test/reg055/expected +9/−0
- test/reg055/reg055.idr +26/−0
- test/reg055/reg055a.idr +15/−0
- test/reg055/run +5/−0
- test/reg056/expected +2/−0
- test/reg056/reg056.idr +15/−0
- test/reg056/run +3/−0
- test/reg057/expected +0/−0
- test/reg057/reg057.idr +8/−0
- test/reg057/run +3/−0
- test/runtest.pl +17/−1
- test/sourceLocation001/SourceLoc.idr +100/−0
- test/sourceLocation001/expected +11/−0
- test/sourceLocation001/run +4/−0
- test/sugar004/expected +3/−0
- test/sugar004/run +6/−0
- test/sugar004/sugar004.idr +36/−0
- test/sugar005/As.idr +36/−0
- test/sugar005/expected +9/−0
- test/sugar005/run +4/−0
- test/totality001/expected +1/−1
- test/totality001/test010.idr +2/−0
- test/totality002/expected +1/−1
- test/totality002/test017.idr +2/−0
- test/totality002/test017a.idr +2/−0
- test/totality006/expected +2/−2
- test/totality006/totality006.idr +3/−1
- test/totality006/totality006a.idr +2/−0
- test/tutorial006/expected +2/−2
- test/tutorial006/tutorial006a.idr +2/−0
Makefile view
@@ -3,6 +3,10 @@ include config.mk -include custom.mk +ifdef CI+CABALFLAGS += -f CI+endif+ install: $(CABAL) install $(CABALFLAGS)
+ codegen/idris-c/Main.hs view
@@ -0,0 +1,44 @@+module Main where++import Idris.Core.TT+import Idris.AbsSyntax+import Idris.ElabDecls+import Idris.REPL++import IRTS.Compiler+import IRTS.CodegenC++import System.Environment+import System.Exit++import Paths_idris++data Opts = Opts { inputs :: [FilePath],+ output :: FilePath }++showUsage = do putStrLn "Usage: idris-c <ibc-files> [-o <output-file>]"+ exitWith ExitSuccess++getOpts :: IO Opts+getOpts = do xs <- getArgs+ return $ process (Opts [] "a.out") xs+ where+ process opts ("-o":o:xs) = process (opts { output = o }) xs+ process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs+ process opts [] = opts++c_main :: Opts -> Idris ()+c_main opts = do elabPrims+ loadInputs (inputs opts) Nothing+ mainProg <- elabMain+ ir <- compile (Via "c") (output opts) mainProg+ runIO $ codegenC ir++main :: IO ()+main = do opts <- getOpts+ if (null (inputs opts)) + then showUsage+ else runMain (c_main opts)+++
config.mk view
@@ -2,7 +2,7 @@ CABAL :=cabal # IDRIS_ENABLE_STATS should not be set in final release # Any flags defined here which alter the RTS API must also be added to src/IRTS/CodegenC.hs-CFLAGS :=-O2 -Wall -DHAS_PTHREAD -DIDRIS_ENABLE_STATS $(CFLAGS)+CFLAGS :=-O2 -Wall -DHAS_PTHREAD -DIDRIS_ENABLE_STATS -msse2 $(CFLAGS) #CABALFLAGS := ## Disable building of Effects
idris.cabal view
@@ -1,5 +1,5 @@ Name: idris-Version: 0.9.15.1+Version: 0.9.16 License: BSD3 License-file: LICENSE Author: Edwin Brady@@ -91,6 +91,8 @@ libs/prelude/prelude.ipkg libs/prelude/Prelude/*.idr libs/prelude/Decidable/*.idr+ libs/prelude/Language/*.idr+ libs/prelude/Language/Reflection/*.idr libs/prelude/Makefile libs/prelude/*.idr @@ -103,7 +105,6 @@ libs/base/Data/Vect/*.idr libs/base/Debug/*.idr libs/base/Decidable/*.idr- libs/base/Language/*.idr libs/base/Language/Reflection/*.idr libs/base/Makefile libs/base/Network/*.idr@@ -273,6 +274,18 @@ test/reg053/run test/reg053/*.idr test/reg053/expected+ test/reg054/run+ test/reg054/*.idr+ test/reg054/expected+ test/reg055/run+ test/reg055/*.idr+ test/reg055/expected+ test/reg056/run+ test/reg056/*.idr+ test/reg056/expected+ test/reg057/run+ test/reg057/*.idr+ test/reg057/expected test/basic001/run test/basic001/*.idr@@ -308,11 +321,19 @@ test/basic011/run test/basic011/*.idr test/basic011/expected+ test/basic012/run+ test/basic012/*.idr+ test/basic012/expected test/buffer001-disabled/*.idr test/buffer001-disabled/run test/buffer001-disabled/expected + test/delab001/*.idr+ test/delab001/run+ test/delab001/expected+ test/delab001/input+ test/dsl001/run test/dsl001/*.idr test/dsl001/expected@@ -331,6 +352,10 @@ test/effects002/run test/effects002/*.idr test/effects002/expected+ test/effects003/run+ test/effects003/*.idr+ test/effects003/expected+ test/effects003/input test/error001/run test/error001/*.idr@@ -344,6 +369,9 @@ test/error004/run test/error004/*.idr test/error004/expected+ test/error005/run+ test/error005/*.idr+ test/error005/expected test/ffi001/run test/ffi001/*.idr@@ -397,7 +425,12 @@ test/idrisdoc008/expected test/idrisdoc008/*.idr test/idrisdoc008/*.ipkg+ test/idrisdoc009/run+ test/idrisdoc009/expected+ test/idrisdoc009/input+ test/idrisdoc009/*.idr + test/interactive001/run test/interactive001/input test/interactive001/*.idr@@ -483,6 +516,10 @@ test/records003/*.idr test/records003/expected + test/sourceLocation001/run+ test/sourceLocation001/*.idr+ test/sourceLocation001/expected+ test/sugar001/run test/sugar001/*.idr test/sugar001/expected@@ -492,7 +529,14 @@ test/sugar003/run test/sugar003/*.idr test/sugar003/expected+ test/sugar004/run+ test/sugar004/*.idr+ test/sugar004/expected+ test/sugar005/run+ test/sugar005/*.idr+ test/sugar005/expected + test/totality001/run test/totality001/*.idr test/totality001/expected@@ -579,6 +623,11 @@ Default: False manual: True +Flag CI+ Description: Built everything using "-Werror", meant for CI-builds only+ Default: False+ manual: True+ Library hs-source-dirs: src Exposed-modules:@@ -591,13 +640,13 @@ , Idris.Core.Execute , Idris.Core.ProofState , Idris.Core.ProofTerm- , Idris.Core.TC , Idris.Core.TT , Idris.Core.Typecheck , Idris.Core.Unify , Idris.Elab.Utils , Idris.Elab.Type+ , Idris.Elab.AsPat , Idris.Elab.Clause , Idris.Elab.Data , Idris.Elab.Record@@ -696,13 +745,13 @@ , bytestring < 0.11 , cheapskate < 0.2 , containers >= 0.5 && < 0.6- , deepseq < 1.4+ , deepseq < 1.5 , directory >= 1.2 && < 1.3 , filepath < 1.4 , fingertree >= 0.1 && < 0.2 , haskeline >= 0.7 && < 0.8- , lens >= 4.1.1 && < 4.5- , mtl < 2.3+ , lens >= 4.1.1 && < 4.8+ , mtl >= 2.2.1 && < 2.3 , network < 2.7 , optparse-applicative >= 0.11 && < 0.12 , parsers >= 0.9 && < 0.13@@ -713,6 +762,7 @@ , time >= 1.4 && < 1.6 , transformers < 0.5 , trifecta >= 1.1 && < 1.6+ , uniplate >=1.6 && < 1.7 , unordered-containers < 0.3 , utf8-string < 0.4 , vector < 0.11@@ -757,6 +807,8 @@ if flag(freestanding) other-modules: Target_idris cpp-options: -DFREESTANDING+ if flag(CI)+ ghc-options: -Werror Executable idris Main-is: Main.hs@@ -765,25 +817,26 @@ Build-depends: idris , base , filepath+ , directory , haskeline >= 0.7 , transformers ghc-prof-options: -auto-all -caf-all ghc-options: -threaded -rtsopts -funbox-strict-fields --- Executable idris-c--- Main-is: Main.hs--- hs-source-dirs: codegen/idris-c--- --- Build-depends: idris--- , base--- , filepath--- , haskeline >= 0.7--- , transformers--- --- ghc-prof-options: -auto-all -caf-all--- ghc-options: -threaded -rtsopts -funbox-strict-fields+Executable idris-c+ Main-is: Main.hs+ hs-source-dirs: codegen/idris-c + Build-depends: idris+ , base+ , filepath+ , haskeline >= 0.7+ , transformers++ ghc-prof-options: -auto-all -caf-all+ ghc-options: -threaded -rtsopts -funbox-strict-fields+ Executable idris-javascript Main-is: Main.hs hs-source-dirs: codegen/idris-javascript@@ -795,7 +848,7 @@ , transformers ghc-prof-options: -auto-all -caf-all- ghc-options: -threaded -rtsopts -funbox-strict-fields+ ghc-options: -threaded -rtsopts -funbox-strict-fields -O2 Executable idris-node Main-is: Main.hs@@ -808,4 +861,4 @@ , transformers ghc-prof-options: -auto-all -caf-all- ghc-options: -threaded -rtsopts -funbox-strict-fields+ ghc-options: -threaded -rtsopts -funbox-strict-fields -O2
libs/base/Control/Arrow.idr view
@@ -5,15 +5,28 @@ %access public +infixr 5 <++> infixr 3 *** infixr 3 &&&+infixr 2 ++++infixr 2 \|/ class Category arr => Arrow (arr : Type -> Type -> Type) where arrow : (a -> b) -> arr a b first : arr a b -> arr (a, c) (b, c)+ second : arr a b -> arr (c, a) (c, b)+ second f = arrow swap >>> first f >>> arrow swap where+ swap : (x,y) -> (y,x)+ swap (x,y) = (y,x)+ (***) : arr a b -> arr a' b' -> arr (a, a') (b, b')+ f *** g = first f >>> second g+ (&&&) : arr a b -> arr a b' -> arr a (b, b')+ f &&& g = arrow dup >>> f *** g where+ dup : x -> (x,x)+ dup x = (x,x) instance Arrow Morphism where arrow f = Mor f@@ -37,3 +50,56 @@ (Kleisli f) &&& (Kleisli g) = Kleisli $ \a => do x <- f a y <- g a return (x, y)++class Arrow arr => ArrowZero (arr : Type -> Type -> Type) where+ zeroArrow : arr a b++class ArrowZero arr => ArrowPlus (arr : Type -> Type -> Type) where+ (<++>) : arr a b -> arr a b -> arr a b++class Arrow arr => ArrowChoice (arr : Type -> Type -> Type) where+ left : arr a b -> arr (Either a c) (Either b c)++ right : arr a b -> arr (Either c a) (Either c b)+ right f = arrow swap >>> left f >>> arrow swap where+ swap : Either a b -> Either b a+ swap (Left x) = Right x+ swap (Right x) = Left x++ (+++) : arr a b -> arr c d -> arr (Either a c) (Either b d)+ f +++ g = left f >>> right g++ (\|/) : arr a b -> arr c b -> arr (Either a c) b+ f \|/ g = f +++ g >>> arrow fromEither++instance Monad m => ArrowChoice (Kleislimorphism m) where+ left f = f +++ (arrow id)+ right f = (arrow id) +++ f+ f +++ g = (f >>> (arrow Left)) \|/ (g >>> (arrow Right))+ (Kleisli f) \|/ (Kleisli g) = Kleisli (either f g)++class Arrow arr => ArrowApply (arr : Type -> Type -> Type) where+ app : arr (arr a b, a) b++instance Monad m => ArrowApply (Kleislimorphism m) where+ app = Kleisli $ \(Kleisli f, x) => f x++data ArrowMonad : (Type -> Type -> Type) -> Type -> Type where+ MkArrowMonad : (runArrowMonad : arr (the Type ()) a) -> ArrowMonad arr a++runArrowMonad : ArrowMonad arr a -> arr (the Type ()) a+runArrowMonad (MkArrowMonad a) = a++instance Arrow a => Functor (ArrowMonad a) where+ map f (MkArrowMonad m) = MkArrowMonad $ m >>> arrow f++instance Arrow a => Applicative (ArrowMonad a) where+ pure x = MkArrowMonad $ arrow $ \_ => x+ (MkArrowMonad f) <$> (MkArrowMonad x) = MkArrowMonad $ f &&& x >>> arrow (uncurry id)++instance ArrowApply a => Monad (ArrowMonad a) where+ (MkArrowMonad m) >>= f =+ MkArrowMonad $ m >>> (arrow $ \x => (runArrowMonad (f x), ())) >>> app++class Arrow arr => ArrowLoop (arr : Type -> Type -> Type) where+ loop : arr (Pair a c) (Pair b c) -> arr a b
libs/base/Control/Isomorphism.idr view
@@ -1,6 +1,7 @@ module Control.Isomorphism import Syntax.PreorderReasoning+import Data.Fin %default total
libs/base/Control/Monad/Reader.idr view
@@ -2,6 +2,7 @@ import Builtins import Control.Monad.Identity+import Control.Monad.Trans %access public @@ -40,6 +41,9 @@ instance Monad m => MonadReader r (ReaderT r m) where ask = RD return local f (RD m) = RD $ m . f++instance MonadTrans (ReaderT r) where+ lift x = RD (const x) ||| Evaluate a function in the context of a Reader monad asks : MonadReader r m => (r -> a) -> m a
libs/base/Control/Monad/State.idr view
@@ -1,6 +1,7 @@ module Control.Monad.State import Control.Monad.Identity+import Control.Monad.Trans %access public @@ -36,6 +37,10 @@ instance Monad m => MonadState s (StateT s m) where get = ST (\x => return (x, x)) put x = ST (\y => return ((), x))++instance MonadTrans (StateT s) where+ lift x = ST (\st => do r <- x+ return (r, st)) ||| Apply a function to modify the context of this computation modify : MonadState s m => (s -> s) -> m ()
+ libs/base/Control/Monad/Trans.idr view
@@ -0,0 +1,4 @@+module Control.Monad.Trans++class MonadTrans (t : (Type -> Type) -> Type -> Type) where+ lift : Monad m => m a -> t m a
libs/base/Control/Monad/Writer.idr view
@@ -2,6 +2,7 @@ import Builtins import Control.Monad.Identity+import Control.Monad.Trans %access public @@ -43,6 +44,10 @@ return ((a, w), w) pass (WR m) = WR $ do ((a, f), w) <- m return (a, f w)++instance Monoid w => MonadTrans (WriterT w) where+ lift x = WR $ do r <- x+ return (r, neutral) ||| Run an action in the Writer monad and transform the written output listens : MonadWriter w m => (w -> b) -> m a -> m (a, b)
libs/base/Data/Bits.idr view
@@ -1,5 +1,7 @@ module Data.Bits +import Data.Fin+ %default total divCeil : Nat -> Nat -> Nat
libs/base/Data/BoundedList.idr view
@@ -1,5 +1,7 @@ module Data.BoundedList +import Data.Fin+ %access public %default total
libs/base/Data/Buffer.idr view
@@ -1,5 +1,7 @@ module Data.Buffer +import Data.Fin+ %default total -- !!! TODO: Open issues:
+ libs/base/Data/Fin.idr view
@@ -0,0 +1,187 @@+module Data.Fin++%default total++||| Numbers strictly less than some bound. The name comes from "finite sets".+|||+||| It's probably not a good idea to use `Fin` for arithmetic, and they will be+||| exceedingly inefficient at run time.+||| @ n the upper bound+data Fin : (n : Nat) -> Type where+ FZ : Fin (S k)+ FS : Fin k -> Fin (S k)++instance Uninhabited (Fin Z) where+ uninhabited FZ impossible+ uninhabited (FS f) impossible++FSInjective : (m : Fin k) -> (n : Fin k) -> FS m = FS n -> m = n+FSInjective left _ Refl = Refl++instance Eq (Fin n) where+ (==) FZ FZ = True+ (==) (FS k) (FS k') = k == k'+ (==) _ _ = False++||| There are no elements of `Fin Z`+FinZAbsurd : Fin Z -> Void+FinZAbsurd FZ impossible++FinZElim : Fin Z -> a+FinZElim x = void (FinZAbsurd x)++||| Convert a Fin to a Nat+finToNat : Fin n -> Nat+finToNat FZ = Z+finToNat (FS k) = S (finToNat k)++||| `finToNat` is injective+finToNatInjective : (fm : Fin k) -> (fn : Fin k) -> (finToNat fm) = (finToNat fn) -> fm = fn+finToNatInjective FZ FZ Refl = Refl+finToNatInjective (FS m) FZ Refl impossible+finToNatInjective FZ (FS n) Refl impossible+finToNatInjective (FS m) (FS n) prf =+ cong (finToNatInjective m n (succInjective (finToNat m) (finToNat n) prf)) ++instance Cast (Fin n) Nat where+ cast x = finToNat x++||| Convert a Fin to an Integer+finToInteger : Fin n -> Integer+finToInteger FZ = 0+finToInteger (FS k) = 1 + finToInteger k++instance Cast (Fin n) Integer where+ cast x = finToInteger x++||| Weaken the bound on a Fin by 1+weaken : Fin n -> Fin (S n)+weaken FZ = FZ+weaken (FS k) = FS (weaken k)++||| Weaken the bound on a Fin by some amount+weakenN : (n : Nat) -> Fin m -> Fin (m + n)+weakenN n FZ = FZ+weakenN n (FS f) = FS (weakenN n f)++||| Attempt to tighten the bound on a Fin.+||| Return `Left` if the bound could not be tightened, or `Right` if it could.+strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n)+strengthen {n = S k} FZ = Right FZ+strengthen {n = S k} (FS i) with (strengthen i)+ strengthen (FS k) | Left x = Left (FS x)+ strengthen (FS k) | Right x = Right (FS x)+strengthen f = Left f++||| Add some natural number to a Fin, extending the bound accordingly+||| @ n the previous bound+||| @ m the number to increase the Fin by+shift : (m : Nat) -> Fin n -> Fin (m + n)+shift Z f = f+shift {n=n} (S m) f = FS {k = (m + n)} (shift m f)++||| The largest element of some Fin type+last : Fin (S n)+last {n=Z} = FZ+last {n=S _} = FS last++total FSinjective : {f : Fin n} -> {f' : Fin n} -> (FS f = FS f') -> f = f'+FSinjective Refl = Refl++instance Ord (Fin n) where+ compare FZ FZ = EQ+ compare FZ (FS _) = LT+ compare (FS _) FZ = GT+ compare (FS x) (FS y) = compare x y+ +instance MinBound (Fin (S n)) where+ minBound = FZ++instance MaxBound (Fin (S n)) where+ maxBound = last+++||| Add two Fins, extending the bound+(+) : Fin n -> Fin m -> Fin (n + m)+(+) {n=S n} {m=m} FZ f' = rewrite plusCommutative n m in weaken (weakenN n f')+(+) (FS f) f' = FS (f + f')++||| Substract two Fins, keeping the bound of the minuend+(-) : Fin n -> Fin m -> Fin n+FZ - _ = FZ+f - FZ = f+(FS f) - (FS f') = weaken $ f - f'++||| Multiply two Fins, extending the bound+(*) : Fin n -> Fin m -> Fin (n * m)+(*) {n=Z} f f' = FinZElim f+(*) {m=Z} f f' = FinZElim f'+(*) {n=S n} {m=S m} FZ f' = FZ+(*) {n=S n} {m=S m} (FS f) f' = f' + (f * f')++-- Construct a Fin from an integer literal which must fit in the given Fin++natToFin : Nat -> (n : Nat) -> Maybe (Fin n)+natToFin Z (S j) = Just FZ+natToFin (S k) (S j) with (natToFin k j)+ | Just k' = Just (FS k')+ | Nothing = Nothing+natToFin _ _ = Nothing++integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)+integerToFin x Z = Nothing -- make sure 'n' is concrete, to save reduction!+integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing++||| Allow overloading of Integer literals for Fin.+||| @ x the Integer that the user typed+||| @ prf an automatically-constructed proof that `x` is in bounds+fromInteger : (x : Integer) ->+ {default ItIsJust+ prf : (IsJust (integerToFin x n))} ->+ Fin n+fromInteger {n} x {prf} with (integerToFin x n)+ fromInteger {n} x {prf = ItIsJust} | Just y = y++%language ErrorReflection++total+finFromIntegerErrors : Err -> Maybe (List ErrorReportPart)+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+ ]+ ]+finFromIntegerErrors _ = Nothing++%error_handlers Data.Fin.fromInteger prf finFromIntegerErrors++instance Enum (Fin (S n)) where+ pred FZ = FZ+ pred (FS n) = weaken n+ succ n = case strengthen (FS n) of+ Left _ => last+ Right k => k+ toNat n = cast n+ fromNat {n=n} m = case natToFin m (S n) of+ Just k => k+ Nothing => last++--------------------------------------------------------------------------------+-- DecEq+--------------------------------------------------------------------------------++total FZNotFS : {f : Fin n} -> FZ {k = n} = FS f -> Void+FZNotFS Refl impossible++instance DecEq (Fin n) where+ decEq FZ FZ = Yes Refl+ decEq FZ (FS f) = No FZNotFS+ decEq (FS f) FZ = No $ negEqSym FZNotFS+ decEq (FS f) (FS f') with (decEq f f')+ | Yes p = Yes $ cong p+ | No p = No $ \h => p $ FSinjective {f = f} {f' = f'} h
libs/base/Data/Fun.idr view
@@ -1,5 +1,7 @@ module Data.Fun +import Data.Vect+ %default total ||| Build an n-ary function type from a Vect of Types and a result type
libs/base/Data/HVect.idr view
@@ -1,5 +1,6 @@ module Data.HVect +import Data.Fin import Data.Vect %access public
libs/base/Data/Hash.idr view
@@ -1,5 +1,7 @@ module Data.Hash +import Data.Vect+ %access public %default total
+ libs/base/Data/Matrix.idr view
@@ -0,0 +1,256 @@+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/So.idr view
@@ -0,0 +1,25 @@+module Data.So++%default total++||| Ensure that some run-time Boolean test has been performed.+|||+||| This lifts a Boolean predicate to the type level. See the function `choose`+||| if you need to perform a Boolean test and convince the type checker of this+||| fact.+|||+||| If you find yourself using `So` for something other than primitive types,+||| it may be appropriate to define a type of evidence for the property that you+||| care about instead.+data So : Bool -> Type where + Oh : So True++instance Uninhabited (So False) where+ uninhabited Oh impossible++||| Perform a case analysis on a Boolean, providing clients with a `So` proof+choose : (b : Bool) -> Either (So b) (So (not b))+choose True = Left Oh+choose False = Right Oh++
libs/base/Data/Vect.idr view
@@ -1,6 +1,7 @@ module Data.Vect import Language.Reflection+import public Data.VectType %access public %default total
libs/base/Data/Vect/Quantifiers.idr view
@@ -1,5 +1,7 @@ module Data.Vect.Quantifiers +import Data.Vect+ ||| A proof that some element of a vector satisfies some property ||| ||| @ P the property to be satsified
+ libs/base/Data/VectType.idr view
@@ -0,0 +1,598 @@+module Data.VectType ++import Data.Fin++%access public+%default total++namespace Vect {+ +infixr 7 ::++%elim data Vect : Nat -> Type -> Type where+ Nil : Vect Z a+ (::) : (x : a) -> (xs : Vect n a) -> Vect (S n) a++-- Hints for interactive editing+%name Vect xs,ys,zs,ws++--------------------------------------------------------------------------------+-- Length+--------------------------------------------------------------------------------++||| Calculate the length of a `Vect`.+|||+||| **Note**: this is only useful if you don't already statically know the length+||| and you want to avoid matching the implicit argument for erasure reasons.+||| @ n the length (provably equal to the return value)+||| @ xs the vector+length : (xs : Vect n a) -> Nat+length [] = 0+length (x::xs) = 1 + length xs++||| Show that the length function on vectors in fact calculates the length+private lengthCorrect : (n : Nat) -> (xs : Vect n a) -> length xs = n+lengthCorrect Z [] = Refl+lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in Refl++--------------------------------------------------------------------------------+-- Indexing into vectors+--------------------------------------------------------------------------------++||| All but the first element of the vector+tail : Vect (S n) a -> Vect n a+tail (x::xs) = xs++||| Only the first element of the vector+head : Vect (S n) a -> a+head (x::xs) = x++||| The last element of the vector+last : Vect (S n) a -> a+last (x::[]) = x+last (x::y::ys) = last $ y::ys++||| All but the last element of the vector+init : Vect (S n) a -> Vect n a+init (x::[]) = []+init (x::y::ys) = x :: init (y::ys)++||| Extract a particular element from a vector+index : Fin n -> Vect n a -> a+index FZ (x::xs) = x+index (FS k) (x::xs) = index k xs+++||| Insert an element at a particular index+insertAt : Fin (S n) -> a -> Vect n a -> Vect (S n) a+insertAt FZ y xs = y :: xs+insertAt (FS k) y (x::xs) = x :: insertAt k y xs+insertAt (FS k) y [] = absurd k++||| Construct a new vector consisting of all but the indicated element+deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a+deleteAt FZ (x::xs) = xs+deleteAt {n = S m} (FS k) (x::xs) = x :: deleteAt k xs+deleteAt {n = Z} (FS k) (x::xs) = absurd k+deleteAt _ [] impossible++||| Replace an element at a particlar index with another+replaceAt : Fin n -> t -> Vect n t -> Vect n t+replaceAt FZ y (x::xs) = y :: xs+replaceAt (FS k) y (x::xs) = x :: replaceAt k y xs++||| Replace the element at a particular index with the result of applying a function to it+||| @ i the index to replace at+||| @ f the update function+||| @ xs the vector to replace in+updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t+updateAt FZ f (x::xs) = f x :: xs+updateAt (FS k) f (x::xs) = x :: updateAt k f xs++--------------------------------------------------------------------------------+-- Subvectors+--------------------------------------------------------------------------------++||| Get the first m elements of a Vect+||| @ m the number of elements to take+take : (n : Nat) -> Vect (n + m) a -> Vect n a+take Z xs = []+take (S k) (x :: xs) = x :: take k xs++||| Remove the first m elements of a Vect+||| @ m the number of elements to remove+drop : (n : Nat) -> Vect (n + m) a -> Vect m a+drop Z xs = xs+drop (S k) (x :: xs) = drop k xs++||| Take the longest prefix of a Vect such that all elements satisfy some+||| Boolean predicate.+|||+||| @ p the predicate+takeWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a)+takeWhile p [] = (_ ** [])+takeWhile p (x::xs) =+ let (len ** ys) = takeWhile p xs+ in if p x then+ (S len ** x :: ys)+ else+ (_ ** [])++||| Remove the longest prefix of a Vect such that all removed elements satisfy some+||| Boolean predicate.+|||+||| @ p the predicate+dropWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a)+dropWhile p [] = (_ ** [])+dropWhile p (x::xs) =+ if p x then+ dropWhile p xs+ else+ (_ ** x::xs)++--------------------------------------------------------------------------------+-- Transformations+--------------------------------------------------------------------------------++||| Reverse the order of the elements of a vector+reverse : Vect n a -> Vect n a+reverse xs = go [] xs+ where go : Vect n a -> Vect m a -> Vect (n+m) a+ go {n} acc [] = rewrite plusZeroRightNeutral n in acc+ go {n} {m=S m} acc (x :: xs) = rewrite sym $ plusSuccRightSucc n m+ in go (x::acc) xs++||| Alternate an element between the other elements of a vector+||| @ sep the element to intersperse+||| @ xs the vector to separate with `sep`+intersperse : (sep : a) -> (xs : Vect n a) -> Vect (n + pred n) a+intersperse sep [] = []+intersperse sep (x::xs) = x :: intersperse' sep xs+ where+ intersperse' : a -> Vect n a -> Vect (n + n) a+ intersperse' sep [] = []+ intersperse' {n=S n} sep (x::xs) = rewrite sym $ plusSuccRightSucc n n+ in sep :: x :: intersperse' sep xs++--------------------------------------------------------------------------------+-- Conversion from list (toList is provided by Foldable)+--------------------------------------------------------------------------------+++fromList' : Vect n a -> (l : List a) -> Vect (length l + n) a+fromList' ys [] = ys+fromList' {n} ys (x::xs) =+ rewrite (plusSuccRightSucc (length xs) n) ==>+ Vect (plus (length xs) (S n)) a in+ fromList' (x::ys) xs++||| Convert a list to a vector.+|||+||| The length of the list should be statically known.+fromList : (l : List a) -> Vect (length l) a+fromList l =+ rewrite (sym $ plusZeroRightNeutral (length l)) in+ reverse $ fromList' [] l++--------------------------------------------------------------------------------+-- Building (bigger) vectors+--------------------------------------------------------------------------------++||| Append two vectors+(++) : Vect m a -> Vect n a -> Vect (m + n) a+(++) [] ys = ys+(++) (x::xs) ys = x :: xs ++ ys++||| Repeate some value n times+||| @ n the number of times to repeat it+||| @ x the value to repeat+replicate : (n : Nat) -> (x : a) -> Vect n a+replicate Z x = []+replicate (S k) x = x :: replicate k x++--------------------------------------------------------------------------------+-- Zips and unzips+--------------------------------------------------------------------------------++||| Combine two equal-length vectors pairwise with some function+zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c+zipWith f [] [] = []+zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys++||| Combine three equal-length vectors into a vector with some function+zipWith3 : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d+zipWith3 f [] [] [] = []+zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs++||| Combine two equal-length vectors pairwise+zip : Vect n a -> Vect n b -> Vect n (a, b)+zip = zipWith (\x,y => (x,y))++||| Combine three equal-length vectors elementwise into a vector of tuples+zip3 : Vect n a -> Vect n b -> Vect n c -> Vect n (a, b, c)+zip3 = zipWith3 (\x,y,z => (x,y,z))++||| Convert a vector of pairs to a pair of vectors+unzip : Vect n (a, b) -> (Vect n a, Vect n b)+unzip [] = ([], [])+unzip ((l, r)::xs) with (unzip xs)+ | (lefts, rights) = (l::lefts, r::rights)++||| Convert a vector of three-tuples to a triplet of vectors+unzip3 : Vect n (a, b, c) -> (Vect n a, Vect n b, Vect n c)+unzip3 [] = ([], [], [])+unzip3 ((l,c,r)::xs) with (unzip3 xs)+ | (lefts, centers, rights) = (l::lefts, c::centers, r::rights)++--------------------------------------------------------------------------------+-- Equality+--------------------------------------------------------------------------------++instance (Eq a) => Eq (Vect n a) where+ (==) [] [] = True+ (==) (x::xs) (y::ys) =+ if x == y then+ xs == ys+ else+ False+++--------------------------------------------------------------------------------+-- Order+--------------------------------------------------------------------------------++instance Ord a => Ord (Vect n a) where+ compare [] [] = EQ+ compare (x::xs) (y::ys) =+ if x /= y then+ compare x y+ else+ compare xs ys+++--------------------------------------------------------------------------------+-- Maps+--------------------------------------------------------------------------------++instance Functor (Vect n) where+ map f [] = []+ map f (x::xs) = f x :: map f xs+++||| Map a partial function across a vector, returning those elements for which+||| the function had a value.+|||+||| The first projection of the resulting pair (ie the length) will always be+||| at most the length of the input vector. This is not, however, guaranteed+||| by the type.+|||+||| @ f the partial function (expressed by returning `Maybe`)+||| @ xs the vector to check for results+mapMaybe : (f : a -> Maybe b) -> (xs : Vect n a) -> (m : Nat ** Vect m b)+mapMaybe f [] = (_ ** [])+mapMaybe f (x::xs) =+ let (len ** ys) = mapMaybe f xs+ in case f x of+ Just y => (S len ** y :: ys)+ Nothing => ( len ** ys)+++--------------------------------------------------------------------------------+-- Folds+--------------------------------------------------------------------------------++total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> Vect n t -> acc+foldrImpl f e go [] = go e+foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs++instance Foldable (Vect n) where+ foldr f e xs = foldrImpl f e id xs++--------------------------------------------------------------------------------+-- Special folds+--------------------------------------------------------------------------------++||| Flatten a vector of equal-length vectors+concat : Vect m (Vect n a) -> Vect (m * n) a+concat [] = []+concat (v::vs) = v ++ concat vs++||| Foldr without seeding the accumulator+foldr1 : (t -> t -> t) -> Vect (S n) t -> t+foldr1 f (x::xs) = foldr f x xs++||| Foldl without seeding the accumulator+foldl1 : (t -> t -> t) -> Vect (S n) t -> t+foldl1 f (x::xs) = foldl f x xs+--------------------------------------------------------------------------------+-- Scans+--------------------------------------------------------------------------------++scanl : (b -> a -> b) -> b -> Vect n a -> Vect (S n) b+scanl f q [] = [q]+scanl f q (x::xs) = q :: scanl f (f q x) xs++--------------------------------------------------------------------------------+-- Membership tests+--------------------------------------------------------------------------------++||| Search for an item using a user-provided test+||| @ p the equality test+||| @ e the item to search for+||| @ xs the vector to search in+elemBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n a) -> Bool+elemBy p e [] = False+elemBy p e (x::xs) with (p e x)+ | True = True+ | False = elemBy p e xs++||| Use the default Boolean equality on elements to search for an item+||| @ x what to search for+||| @ xs where to search+elem : Eq a => (x : a) -> (xs : Vect n a) -> Bool+elem = elemBy (==)++||| Find the association of some key with a user-provided comparison+||| @ p the comparison operator for keys (True if they match)+||| @ e the key to look for+lookupBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n (a, b)) -> Maybe b+lookupBy p e [] = Nothing+lookupBy p e ((l, r)::xs) with (p e l)+ | True = Just r+ | False = lookupBy p e xs++||| Find the assocation of some key using the default Boolean equality test+lookup : Eq a => a -> Vect n (a, b) -> Maybe b+lookup = lookupBy (==)++||| Check if any element of xs is found in elems by a user-provided comparison+||| @ p the comparison operator+||| @ elems the vector to search+||| @ xs what to search for+hasAnyBy : (p : a -> a -> Bool) -> (elems : Vect m a) -> (xs : Vect n a) -> Bool+hasAnyBy p elems [] = False+hasAnyBy p elems (x::xs) with (elemBy p x elems)+ | True = True+ | False = hasAnyBy p elems xs++||| Check if any element of xs is found in elems using the default Boolean equality test+hasAny : Eq a => Vect m a -> Vect n a -> Bool+hasAny = hasAnyBy (==)++--------------------------------------------------------------------------------+-- Searching with a predicate+--------------------------------------------------------------------------------++||| Find the first element of the vector that satisfies some test+||| @ p the test to satisfy+find : (p : a -> Bool) -> (xs : Vect n a) -> Maybe a+find p [] = Nothing+find p (x::xs) with (p x)+ | True = Just x+ | False = find p xs++||| Find the index of the first element of the vector that satisfies some test+findIndex : (a -> Bool) -> Vect n a -> Maybe Nat+findIndex = findIndex' 0+ where+ findIndex' : Nat -> (a -> Bool) -> Vect n a -> Maybe Nat+ findIndex' cnt p [] = Nothing+ findIndex' cnt p (x::xs) with (p x)+ | True = Just cnt+ | False = findIndex' (S cnt) p xs++||| Find the indices of all elements that satisfy some test+total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)+findIndices = findIndices' 0+ where+ total findIndices' : Nat -> (a -> Bool) -> Vect m a -> (p ** Vect p Nat)+ findIndices' cnt p [] = (_ ** [])+ findIndices' cnt p (x::xs) with (findIndices' (S cnt) p xs)+ | (_ ** tail) =+ if p x then+ (_ ** cnt::tail)+ else+ (_ ** tail)++elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe Nat+elemIndexBy p e = findIndex $ p e++elemIndex : Eq a => a -> Vect m a -> Maybe Nat+elemIndex = elemIndexBy (==)++total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat)+elemIndicesBy p e = findIndices $ p e++total elemIndices : Eq a => a -> Vect m a -> (p ** Vect p Nat)+elemIndices = elemIndicesBy (==)++--------------------------------------------------------------------------------+-- Filters+--------------------------------------------------------------------------------++||| Find all elements of a vector that satisfy some test+total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)+filter p [] = ( _ ** [] )+filter p (x::xs) with (filter p xs)+ | (_ ** tail) =+ if p x then+ (_ ** x::tail)+ else+ (_ ** tail)++||| Make the elements of some vector unique by some test+nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)+nubBy = nubBy' []+ where+ nubBy' : Vect m a -> (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)+ nubBy' acc p [] = (_ ** [])+ nubBy' acc p (x::xs) with (elemBy p x acc)+ | True = nubBy' acc p xs+ | False with (nubBy' (x::acc) p xs)+ | (_ ** tail) = (_ ** x::tail)++||| Make the elements of some vector unique by the default Boolean equality+nub : Eq a => Vect n a -> (p ** Vect p a)+nub = nubBy (==)++deleteBy : (a -> a -> Bool) -> a -> Vect n a -> (p ** Vect p a)+deleteBy _ _ [] = (_ ** [])+deleteBy eq x (y::ys) =+ let (len ** zs) = deleteBy eq x ys+ in if x `eq` y then (_ ** ys) else (S len ** y ::zs)++delete : (Eq a) => a -> Vect n a -> (p ** Vect p a)+delete = deleteBy (==)++--------------------------------------------------------------------------------+-- Splitting and breaking lists+--------------------------------------------------------------------------------++||| A tuple where the first element is a Vect of the n first elements and+||| the second element is a Vect of the remaining elements of the original Vect+||| It is equivalent to (take n xs, drop n xs)+||| @ m the index to split at+||| @ xs the Vect to split in two+splitAt : (n : Nat) -> (xs : Vect (n + m) a) -> (Vect n a, Vect m a)+splitAt n xs = (take n xs, drop n xs)++partition : (a -> Bool) -> Vect n a -> ((p ** Vect p a), (q ** Vect q a))+partition p [] = ((_ ** []), (_ ** []))+partition p (x::xs) =+ let ((leftLen ** lefts), (rightLen ** rights)) = partition p xs in+ if p x then+ ((S leftLen ** x::lefts), (rightLen ** rights))+ else+ ((leftLen ** lefts), (S rightLen ** x::rights))++--------------------------------------------------------------------------------+-- Predicates+--------------------------------------------------------------------------------++isPrefixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool+isPrefixOfBy p [] right = True+isPrefixOfBy p left [] = False+isPrefixOfBy p (x::xs) (y::ys) with (p x y)+ | True = isPrefixOfBy p xs ys+ | False = False++isPrefixOf : Eq a => Vect m a -> Vect n a -> Bool+isPrefixOf = isPrefixOfBy (==)++isSuffixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool+isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right)++isSuffixOf : Eq a => Vect m a -> Vect n a -> Bool+isSuffixOf = isSuffixOfBy (==)++--------------------------------------------------------------------------------+-- Conversions+--------------------------------------------------------------------------------++total maybeToVect : Maybe a -> (p ** Vect p a)+maybeToVect Nothing = (_ ** [])+maybeToVect (Just j) = (_ ** [j])++total vectToMaybe : Vect n a -> Maybe a+vectToMaybe [] = Nothing+vectToMaybe (x::xs) = Just x++--------------------------------------------------------------------------------+-- Misc+--------------------------------------------------------------------------------++catMaybes : Vect n (Maybe a) -> (p ** Vect p a)+catMaybes [] = (_ ** [])+catMaybes (Nothing::xs) = catMaybes xs+catMaybes ((Just j)::xs) with (catMaybes xs)+ | (_ ** tail) = (_ ** j::tail)++diag : Vect n (Vect n a) -> Vect n a+diag [] = []+diag ((x::xs)::xss) = x :: diag (map tail xss)++range : Vect n (Fin n)+range {n=Z} = []+range {n=S _} = FZ :: map FS range++||| Transpose a Vect of Vects, turning rows into columns and vice versa.+|||+||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`.+transpose : Vect m (Vect n a) -> Vect n (Vect m a)+transpose [] = replicate _ []+transpose (x :: xs) = zipWith (::) x (transpose xs)++--------------------------------------------------------------------------------+-- Applicative/Monad/Traversable+--------------------------------------------------------------------------------++instance Applicative (Vect k) where+ pure = replicate _++ fs <$> vs = zipWith apply fs vs++instance Monad (Vect n) where+ m >>= f = diag (map f m)++instance Traversable (Vect n) where+ traverse f [] = pure Vect.Nil+ traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |]++--------------------------------------------------------------------------------+-- Show +--------------------------------------------------------------------------------++instance Show a => Show (Vect n a) where+ show = show . toList++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++vectConsCong : (x : a) -> (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> (x :: xs = x :: ys)+vectConsCong x xs xs Refl = Refl++vectNilRightNeutral : (xs : Vect n a) -> xs ++ [] = xs+vectNilRightNeutral [] = Refl+vectNilRightNeutral (x :: xs) =+ vectConsCong _ _ _ (vectNilRightNeutral xs)++vectAppendAssociative : (x : Vect xLen a) -> (y : Vect yLen a) -> (z : Vect zLen a) -> x ++ (y ++ z) = (x ++ y) ++ z+vectAppendAssociative [] y z = Refl+vectAppendAssociative (x :: xs) ys zs =+ vectConsCong _ _ _ (vectAppendAssociative xs ys zs)++}++--------------------------------------------------------------------------------+-- DecEq+--------------------------------------------------------------------------------++total+vectInjective1 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> x = y+vectInjective1 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl++total+vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys+vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl++instance DecEq a => DecEq (Vect n a) where+ decEq [] [] = Yes Refl+ decEq (x :: xs) (y :: ys) with (decEq x y)+ decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys)+ decEq (x :: xs) (x :: xs) | Yes Refl | Yes Refl = Yes Refl+ decEq (x :: xs) (x :: ys) | Yes Refl | No neq = No (neq . vectInjective2)+ decEq (x :: xs) (y :: ys) | No neq = No (neq . vectInjective1)++{- The following definition is elaborated in a wrong case-tree. Examination pending.+instance DecEq a => DecEq (Vect n a) where+ decEq [] [] = Yes Refl+ decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)+ decEq (x :: xs) (x :: xs) | (Yes Refl, Yes Refl) = Yes Refl+ decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p))+ decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p))+-}++-- For the primitives, we have to cheat because we don't have access to their+-- internal implementations.+
+ libs/base/Debug/Error.idr view
@@ -0,0 +1,20 @@+module Debug.Error++import Language.Reflection+import System++||| Terminate the program after printing a user-specified error message.+|||+||| @ loc The source location to display for the error+||| @ message The error to print+partial+error : {default tactics {sourceLocation} loc : SourceLocation} ->+ (message : String) ->+ a+error {loc = FileLoc filename (line, col) _} message =+ believe_me . unsafePerformIO $+ do let place = filename ++ " line " ++ show line ++ " column " ++ show col+ let message' = place ++ ": " ++ message+ putStrLn message'+ exit 1+
libs/base/Decidable/Decidable.idr view
@@ -1,6 +1,7 @@ module Decidable.Decidable import Data.Rel+import Data.Fun %access public @@ -17,6 +18,6 @@ --decision : Decidable ts p => (ts : Vect k Type) -> (p : Rel ts) -> liftRel ts p Dec --decision ts p = decide {ts} {p} -using (P : Type, p : P)- data Given : Dec P -> Type where- always : Given (Yes p)+using (a : Type, x : a)+ data Given : Dec a -> Type where+ Always : Given (Yes x)
libs/base/Decidable/Order.idr view
@@ -2,6 +2,9 @@ import Decidable.Decidable import Decidable.Equality+import Data.Fin+import Data.Fun+import Data.Rel %access public
− libs/base/Language/Reflection.idr
@@ -1,479 +0,0 @@-module Language.Reflection--%access public--data TTName =- ||| A user-provided name- UN String |- ||| A name in some namespace.- |||- ||| The namespace is in reverse order, so `(NS (UN "foo") ["B", "A"])` represents the name `A.B.foo`- NS TTName (List String) |- ||| Machine-chosen names- MN Int String |- ||| Name of something which is never used in scope- NErased-%name TTName n, n'--implicit-userSuppliedName : String -> TTName-userSuppliedName = UN--data TTUExp =- ||| Universe variable- UVar Int |- ||| Explicit universe level- UVal Int-%name TTUExp uexp--data NativeTy = IT8 | IT16 | IT32 | IT64--data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar- | ITVec NativeTy Int--data ArithTy = ATInt Language.Reflection.IntTy | ATFloat--||| Primitive constants-data Const = I Int | BI Integer | Fl Float | Ch Char | Str String- | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64- | B8V Bits8x16 | B16V Bits16x8- | B32V Bits32x4 | B64V Bits64x2- | AType ArithTy | StrType- | PtrType | ManagedPtrType | BufferType | VoidType | Forgot--%name Const c, c'--abstract class ReflConst (a : Type) where- toConst : a -> Const--instance ReflConst Int where- toConst x = I x--instance ReflConst Integer where- toConst = BI--instance ReflConst Float where- toConst = Fl--instance ReflConst Char where- toConst = Ch--instance ReflConst String where- toConst = Str--instance ReflConst Bits8 where- toConst = B8--instance ReflConst Bits16 where- toConst = B16--instance ReflConst Bits32 where- toConst = B32--instance ReflConst Bits64 where- toConst = B64--implicit-reflectConstant: (ReflConst a) => a -> Const-reflectConstant = toConst---||| Types of named references-data NameType =- ||| A reference which is just bound, e.g. by intro- Bound |- ||| A reference to a de Bruijn-indexed variable- Ref |- ||| Data constructor with tag and number- DCon Int Int |- ||| Type constructor with tag and number- TCon Int Int--%name NameType nt, nt'--||| Types annotations for bound variables in different-||| binding contexts-data Binder a = Lam a- | Pi a a- | Let a a- | NLet a a- | Hole a- | GHole a- | Guess a a- | PVar a- | PVTy a-%name Binder b, b'--instance Functor Binder where- map f (Lam x) = Lam (f x)- map f (Pi x k) = Pi (f x) (f k)- map f (Let x y) = Let (f x) (f y)- map f (NLet x y) = NLet (f x) (f y)- map f (Hole x) = Hole (f x)- map f (GHole x) = GHole (f x)- map f (Guess x y) = Guess (f x) (f y)- map f (PVar x) = PVar (f x)- map f (PVTy x) = PVTy (f x)--instance Foldable Binder where- foldr f z (Lam x) = f x z- foldr f z (Pi x k) = f x (f k z)- foldr f z (Let x y) = f x (f y z)- foldr f z (NLet x y) = f x (f y z)- foldr f z (Hole x) = f x z- foldr f z (GHole x) = f x z- foldr f z (Guess x y) = f x (f y z)- foldr f z (PVar x) = f x z- foldr f z (PVTy x) = f x z--instance Traversable Binder where- traverse f (Lam x) = [| Lam (f x) |]- traverse f (Pi x k) = [| Pi (f x) (f k) |]- traverse f (Let x y) = [| Let (f x) (f y) |]- traverse f (NLet x y) = [| NLet (f x) (f y) |]- traverse f (Hole x) = [| Hole (f x) |]- traverse f (GHole x) = [| GHole (f x) |]- traverse f (Guess x y) = [| Guess (f x) (f y) |]- traverse f (PVar x) = [| PVar (f x) |]- traverse f (PVTy x) = [| PVTy (f x) |]---||| Reflection of the well typed core language-data TT =- ||| A reference to some name (P for Parameter)- P NameType TTName TT |- ||| de Bruijn variables- V Int |- ||| Bind a variable- Bind TTName (Binder TT) TT |- ||| Apply one term to another- App TT TT |- ||| Embed a constant- TConst Const |- ||| Argument projection; runtime only- Proj TT Int |- ||| Erased terms- Erased |- ||| Impossible terms- Impossible |- ||| The type of types along (with universe constraints)- TType TTUExp-%name TT tm, tm'--||| Raw terms without types-data Raw =- ||| Variables, global or local- Var TTName |- ||| Bind a variable- RBind TTName (Binder Raw) Raw |- ||| Application- RApp Raw Raw |- ||| The type of types- RType |- RForce Raw |- ||| Embed a constant- RConstant Const-%name Raw tm, tm'--||| Error reports are a list of report parts-data ErrorReportPart =- ||| A human-readable string- TextPart String |- ||| An Idris name (to be semantically coloured)- NamePart TTName |- ||| An Idris term, to be pretty printed- TermPart TT |- ||| An indented sub-report, to provide more details- SubReport (List ErrorReportPart)-%name ErrorReportPart part, p--||| A representation of Idris's tactics that can be returned from custom-||| tactic implementations. Generate these using `applyTactic`.-data Tactic =- ||| Try the first tactic and resort to the second one on failure- Try Tactic Tactic |- ||| Only run if the goal has the right type- GoalType String Tactic |- ||| Resolve function name, find matching arguments in the- ||| context and compute the proof target- Refine TTName |- ||| Apply both tactics in sequence- Seq Tactic Tactic |- ||| Intelligently construct the proof target from the context- Trivial |- ||| Build a proof by applying contructors up to a maximum depth- Search Int |- ||| Resolve a type class- Instance |- ||| Infer the proof target from the context- Solve |- ||| introduce all variables into the context- Intros |- ||| Introduce a named variable into the context, use the- ||| first one if the given name is not found- Intro TTName |- ||| Invoke the reflected rep. of another tactic- ApplyTactic TT |- ||| Turn a value into its reflected representation- Reflect TT |- ||| Use a `%reflection` function- ByReflection TT |- ||| Turn a raw value back into a term- Fill Raw |- ||| Use the given value to conclude the proof- Exact TT |- ||| Focus on a particular hole- Focus TTName |- ||| Rewrite with an equality- Rewrite TT |- ||| Perform induction on a particular expression- Induction TT |- ||| Perform case analysis on a particular expression- Case TT |- ||| Name a reflected term- LetTac TTName TT |- ||| Name a reflected term and type it- LetTacTy TTName TT TT |- ||| Normalise the goal- Compute |- ||| Do nothing- Skip |- ||| Fail with an error message- Fail (List ErrorReportPart)-%name Tactic tac, tac'---||| Things with a canonical representation in the TT datatype.-|||-||| 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- ||| A representation of the type `a`.- |||- ||| This is to enable quoting polymorphic datatypes- quotedTy : TT-- ||| Quote a particular element of `a`.- |||- ||| Each equation should look something like ```quote (Foo x y) = `(Foo ~(quote x) ~(quote y))```- quote : a -> TT--instance Quotable Nat where- quotedTy = `(Nat)-- quote Z = `(Z)- quote (S k) = `(S ~(quote k))--instance Quotable Int where- quotedTy = `(Int)- quote x = TConst (I x)--instance Quotable Float where- quotedTy = `(Float)- quote x = TConst (Fl x)--instance Quotable Char where- quotedTy = `(Char)- quote x = TConst (Ch x)--instance Quotable Bits8 where- quotedTy = `(Bits8)- quote x = TConst (B8 x)--instance Quotable Bits16 where- quotedTy = `(Bits16)- quote x = TConst (B16 x)--instance Quotable Bits32 where- quotedTy = `(Bits32)- quote x = TConst (B32 x)--instance Quotable Bits64 where- quotedTy = `(Bits64)- quote x = TConst (B64 x)--instance Quotable Integer where- quotedTy = `(Integer)- quote x = TConst (BI x)--instance Quotable Bits8x16 where- quotedTy = `(Bits8x16)- quote x = TConst (B8V x)--instance Quotable Bits16x8 where- quotedTy = `(Bits16x8)- quote x = TConst (B16V x)--instance Quotable Bits32x4 where- quotedTy = `(Bits32x4)- quote x = TConst (B32V x)--instance Quotable Bits64x2 where- quotedTy = `(Bits64x2)- quote x = TConst (B64V x)--instance Quotable String where- quotedTy = `(String)- quote x = TConst (Str x)--instance Quotable NameType 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 TTName 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- quotedTy = `(NativeTy)- quote IT8 = `(Reflection.IT8)- quote IT16 = `(Reflection.IT16)- quote IT32 = `(Reflection.IT32)- quote IT64 = `(Reflection.IT64)--instance Quotable Reflection.IntTy where- quotedTy = `(Reflection.IntTy)- quote (ITFixed x) = `(ITFixed ~(quote x))- quote ITNative = `(Reflection.ITNative)- quote ITBig = `(ITBig)- quote ITChar = `(Reflection.ITChar)- quote (ITVec x y) = `(ITVec ~(quote x) ~(quote y))--instance Quotable ArithTy where- quotedTy = `(ArithTy)- quote (ATInt x) = `(ATInt ~(quote x))- quote ATFloat = `(ATFloat)--instance Quotable Const where- quotedTy = `(Const)- quote (I x) = `(I ~(quote x))- quote (BI x) = `(BI ~(quote x))- quote (Fl x) = `(Fl ~(quote x))- quote (Ch x) = `(Ch ~(quote x))- quote (Str x) = `(Str ~(quote x))- quote (B8 x) = `(B8 ~(quote x))- quote (B16 x) = `(B16 ~(quote x))- quote (B32 x) = `(B32 ~(quote x))- quote (B64 x) = `(B64 ~(quote x))- quote (B8V xs) = `(B8V ~(quote xs))- quote (B16V xs) = `(B16V ~(quote xs))- quote (B32V xs) = `(B32V ~(quote xs))- quote (B64V xs) = `(B64V ~(quote xs))- quote (AType x) = `(AType ~(quote x))- quote StrType = `(StrType)- quote PtrType = `(PtrType)- quote ManagedPtrType = `(ManagedPtrType)- quote BufferType = `(BufferType)- quote VoidType = `(VoidType)- quote Forgot = `(Forgot)---instance Quotable TTUExp where- quotedTy = `(TTUExp)- quote (UVar x) = `(UVar ~(quote x))- quote (UVal x) = `(UVal ~(quote x))--mutual- instance Quotable TT where- quotedTy = `(TT)- quote (P nt n tm) = `(P ~(quote nt) ~(quote n) ~(quote tm))- quote (V x) = `(V ~(quote x))- quote (Bind n b tm) = `(Bind ~(quote n) ~(assert_total (quote b)) ~(quote tm))- quote (App f x) = `(App ~(quote f) ~(quote x))- quote (TConst c) = `(TConst ~(quote c))- quote (Proj tm x) = `(Proj ~(quote tm) ~(quote x))- quote Erased = `(Erased)- quote Impossible = `(Impossible)- quote (TType uexp) = `(TType ~(quote uexp))-- instance Quotable (Binder 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))- ~(assert_total (quote k)))- quote (Let x y) = `(Let {a=TT} ~(assert_total (quote x))- ~(assert_total (quote y)))- quote (NLet x y) = `(NLet {a=TT} ~(assert_total (quote x))- ~(assert_total (quote y)))- quote (Hole x) = `(Hole {a=TT} ~(assert_total (quote x)))- quote (GHole x) = `(GHole {a=TT} ~(assert_total (quote x)))- quote (Guess x y) = `(Guess {a=TT} ~(assert_total (quote x))- ~(assert_total (quote y)))- quote (PVar x) = `(PVar {a=TT} ~(assert_total (quote x)))- quote (PVTy x) = `(PVTy {a=TT} ~(assert_total (quote x)))---instance Quotable ErrorReportPart where- quotedTy = `(ErrorReportPart)- quote (TextPart x) = `(TextPart ~(quote x))- quote (NamePart n) = `(NamePart ~(quote n))- quote (TermPart tm) = `(TermPart ~(quote tm))- quote (SubReport xs) = `(SubReport ~(assert_total $ quote xs))--mutual- quoteRaw : Raw -> TT- quoteRaw (Var n) = `(Var ~(quote n))- 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 (RForce tm) = `(RForce ~(quoteRaw tm))- quoteRaw (RConstant c) = `(RConstant ~(quote c))-- quoteRawBinder : Binder Raw -> TT- quoteRawBinder (Lam x) = `(Lam {a=Raw} ~(quoteRaw x))- quoteRawBinder (Pi x k) = `(Pi {a=Raw} ~(quoteRaw x) ~(quoteRaw k))- quoteRawBinder (Let x y) = `(Let {a=Raw} ~(quoteRaw x) ~(quoteRaw y))- quoteRawBinder (NLet x y) = `(NLet {a=Raw} ~(quoteRaw x) ~(quoteRaw y))- quoteRawBinder (Hole x) = `(Hole {a=Raw} ~(quoteRaw x))- quoteRawBinder (GHole x) = `(GHole {a=Raw} ~(quoteRaw x))- quoteRawBinder (Guess x y) = `(Guess {a=Raw} ~(quoteRaw x) ~(quoteRaw y))- quoteRawBinder (PVar x) = `(PVar {a=Raw} ~(quoteRaw x))- quoteRawBinder (PVTy x) = `(PVTy {a=Raw} ~(quoteRaw x))--instance Quotable Raw where- quotedTy = `(Raw)- quote = quoteRaw--instance Quotable (Binder Raw) where- quotedTy = `(Binder Raw)- quote = quoteRawBinder--instance Quotable Tactic 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 (Seq tac tac') = `(Seq ~(quote tac) ~(quote tac'))- quote Trivial = `(Trivial)- quote (Search x) = `(Search ~(quote x))- quote Instance = `(Instance)- quote Solve = `(Solve)- quote Intros = `(Intros)- quote (Intro n) = `(Intro ~(quote n))- quote (ApplyTactic tm) = `(ApplyTactic ~(quote tm))- quote (Reflect tm) = `(Reflect ~(quote tm))- quote (ByReflection tm) = `(ByReflection ~(quote tm))- quote (Fill tm) = `(Fill ~(quote tm))- quote (Exact tm) = `(Exact ~(quote tm))- quote (Focus n) = `(Focus ~(quote n))- quote (Rewrite tm) = `(Rewrite ~(quote tm))- quote (Induction tm) = `(Induction ~(quote tm))- quote (Case tm) = `(Case ~(quote tm))- quote (LetTac n tm) = `(LetTac ~(quote n) ~(quote tm))- quote (LetTacTy n tm tm') = `(LetTacTy ~(quote n) ~(quote tm) ~(quote tm'))- quote Compute = `(Compute)- quote Skip = `(Skip)- quote (Fail xs) = `(Fail ~(quote xs))
− libs/base/Language/Reflection/Errors.idr
@@ -1,45 +0,0 @@-module Language.Reflection.Errors--import Language.Reflection--data SourceLocation : Type where- FileLoc : (filename : String) -> (start : (Int, Int)) -> (end : (Int, Int)) -> SourceLocation--%name SourceLocation loc--data Err = Msg String- | InternalMsg String- | CantUnify Bool TT TT Err (List (TTName, TT)) Int- -- Int is 'score' - how much we did unify- -- Bool indicates recoverability, True indicates more info may make- -- unification succeed- | InfiniteUnify TTName TT (List (TTName, TT))- | CantConvert TT TT (List (TTName, TT))- | CantSolveGoal TT (List (TTName, TT))- | UnifyScope TTName TTName TT (List (TTName, TT))- | CantInferType String- | NonFunctionType TT TT- | NotEquality TT TT- | TooManyArguments TTName- | CantIntroduce TT- | NoSuchVariable TTName- | NoTypeDecl TTName- | NotInjective TT TT TT- | CantResolve TT- | CantResolveAlts (List String)- | IncompleteTerm TT- | UniverseError- | ProgramLineComment- | Inaccessible TTName- | NonCollapsiblePostulate TTName- | AlreadyDefined TTName- | ProofSearchFail Err- | NoRewriting TT- | ProviderError String- | LoadingFailed String Err--%name Err err, e---- Error reports become functions in List (String, TT) -> Err -> ErrorReport-ErrorHandler : Type-ErrorHandler = Err -> Maybe (List ErrorReportPart)
libs/base/Language/Reflection/Utils.idr view
@@ -3,17 +3,17 @@ import Language.Reflection import Language.Reflection.Errors -%default total- -------------------------------------------------------- -- Tactic construction conveniences -------------------------------------------------------- +total seq : List Tactic -> Tactic seq [] = GoalType "This is an impossible case" Trivial seq [t] = t seq (t::ts) = t `Seq` seq ts +total try : List Tactic -> Tactic try [] = GoalType "This is an impossible case" Trivial try [t] = t@@ -23,6 +23,7 @@ -------------------------------------------------------- -- For use in tactic scripts --------------------------------------------------------+total mkPair : a -> b -> (a, b) mkPair a b = (a, b) @@ -30,22 +31,25 @@ -------------------------------------------------------- -- Tools for constructing proof terms directly ---------------------------------------------------------+total getUName : TTName -> Maybe String getUName (UN n) = Just n getUName (NS n ns) = getUName n getUName _ = Nothing +total unApply : TT -> (TT, List TT) unApply t = unA t [] where unA : TT -> List TT -> (TT, List TT) unA (App fn arg) args = unA fn (arg::args) unA tm args = (tm, args) +total mkApp : TT -> List TT -> TT mkApp tm [] = tm mkApp tm (a::as) = mkApp (App tm a) as +total binderTy : (Eq t) => Binder t -> t binderTy (Lam t) = t binderTy (Pi t _) = t@@ -261,6 +265,8 @@ show (TooManyArguments n) = "TooManyArguments " ++ show n show (CantIntroduce tm) = "CantIntroduce " ++ show tm show (NoSuchVariable n) = "NoSuchVariable " ++ show n+ show (WithFnType tm) = "WithFnType " ++ show tm+ show (CantMatch tm) = "CantMatch " ++ show tm show (NoTypeDecl n) = "NoTypeDecl " ++ show n show (NotInjective tm tm' x) = "NotInjective " ++ show tm ++ " " ++ show tm' show (CantResolve tm) = "CantResolve " ++ show tm
libs/base/Network/Socket.idr view
@@ -56,13 +56,13 @@ show NotASocket = "Not a socket" show Stream = "Stream" show Datagram = "Datagram"- show Raw = "Raw"+ show RawSocket = "Raw" instance ToCode SocketType where toCode NotASocket = 0 toCode Stream = 1 toCode Datagram = 2- toCode Raw = 3+ toCode RawSocket = 3 data RecvStructPtr = RSPtr Ptr
libs/base/System.idr view
@@ -1,7 +1,5 @@ module System -import Prelude- %include C "unistd.h" %default partial %access public
libs/base/base.ipkg view
@@ -4,7 +4,7 @@ modules = System, Network.Cgi, Network.Socket,- Debug.Trace,+ Debug.Error, Debug.Trace, System.Info, System.Concurrency.Raw, System.Concurrency.Process,@@ -13,7 +13,7 @@ Providers, - Language.Reflection, Language.Reflection.Utils, Language.Reflection.Errors,+ Language.Reflection.Utils, Syntax.PreorderReasoning, @@ -21,16 +21,18 @@ Data.Bits, Data.Mod2, Data.ZZ, Data.Sign, Data.SortedMap, Data.SortedSet, Data.BoundedList,- Data.Vect, Data.HVect, Data.Vect.Quantifiers,+ 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.List, Data.Hash, Data.Matrix,+ Data.So, Control.Isomorphism, Control.Isomorphism.Primitives, 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-
libs/effects/Effect/Default.idr view
@@ -1,5 +1,7 @@ module Default +import Data.Vect+ class Default a where default : a
libs/effects/Effect/File.idr view
@@ -87,6 +87,20 @@ handle (FH h) EOF k = do e <- feof h k e (FH h) +instance Handler FileIO (IOExcept a) where+ handle () (Open fname m) k = do h <- ioe_lift $ openFile fname m+ valid <- ioe_lift $ validFile h+ if valid then k True (FH h)+ else k False ()+ handle (FH h) Close k = do ioe_lift $ closeFile h+ k () ()+ handle (FH h) ReadLine k = do str <- ioe_lift $ fread h+ k str (FH h)+ handle (FH h) (WriteString str) k = do ioe_lift $ fwrite h str+ k () (FH h)+ handle (FH h) EOF k = do e <- ioe_lift $ feof h+ k e (FH h)+ -- -------------------------------------------------------------- [ The Effect ] FILE_IO : Type -> EFFECT FILE_IO t = MkEff t FileIO
libs/effects/Effect/Memory.idr view
@@ -2,6 +2,8 @@ import Effects import Control.IOExcept+import Data.Vect+import public Data.So %access public @@ -64,11 +66,11 @@ private do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8)-do_peek _ _ Z = return (Prelude.Vect.Nil)+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) bs <- do_peek ptr (S offset) n- Prelude.Monad.return (Prelude.Vect.(::) b bs)+ Monad.return (Vect.(::) b bs) private do_poke : Ptr -> Nat -> Vect size Bits8 -> IO ()
libs/effects/Effect/Random.idr view
@@ -1,6 +1,8 @@ module Effect.Random import Effects+import Data.Vect+import Data.Fin data Random : Effect where getRandom : { Integer } Random Integer @@ -19,7 +21,7 @@ ||| Generates a random Integer in a given range rndInt : Integer -> Integer -> { [RND] } Eff Integer rndInt lower upper = do v <- call $ getRandom- return (v `prim__sremBigInt` (upper - lower) + lower)+ return ((v `prim__sremBigInt` (upper - lower)) + lower) ||| Generate a random number in Fin (S `k`) |||
libs/effects/Effects.idr view
@@ -1,8 +1,8 @@ module Effects import Language.Reflection-import Control.Catchable-import Effect.Default+import public Effect.Default+import Data.Vect --- Effectful computations are described as algebraic data types that --- explain how an effect is interpreted in some underlying context.
libs/prelude/Builtins.idr view
@@ -9,25 +9,26 @@ ||| The trivial constructor for `()`. MkUnit -||| The non-dependent pair type, also known as conjunction.-||| @A the type of the left elements in the pair-||| @B the type of the left elements in the pair-data Pair : (A : Type) -> (B : Type) -> Type where- ||| A pair of elements- ||| @a the left element of the pair- ||| @b the right element of the pair- MkPair : {A, B : Type} -> (a : A) -> (b : B) -> Pair A B+namespace Builtins+ ||| The non-dependent pair type, also known as conjunction.+ ||| @A the type of the left elements in the pair+ ||| @B the type of the left elements in the pair+ %elim data Pair : (A : Type) -> (B : Type) -> Type where+ ||| A pair of elements+ ||| @a the left element of the pair+ ||| @b the right element of the pair+ MkPair : {A, B : Type} -> (a : A) -> (b : B) -> Pair A B -||| Dependent pairs-|||-||| Dependent pairs represent existential quantification - they consist of a-||| witness for the existential claim and a proof that the property holds for-||| it. Another way to see dependent pairs is as just data - for instance, the-||| length of a vector paired with that vector.-|||-||| @ a the type of the witness @ P the type of the proof-data Sigma : (a : Type) -> (P : a -> Type) -> Type where- MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P+ ||| Dependent pairs+ |||+ ||| Dependent pairs represent existential quantification - they consist of a+ ||| witness for the existential claim and a proof that the property holds for+ ||| it. Another way to see dependent pairs is as just data - for instance, the+ ||| length of a vector paired with that vector.+ |||+ ||| @ a the type of the witness @ P the type of the proof+ data Sigma : (a : Type) -> (P : a -> Type) -> Type where+ MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P ||| The empty type, also known as the trivially false proposition. |||@@ -115,14 +116,14 @@ -- is better in any case? par (Delay x) = x -||| Assert to the totality checker than y is always structurally smaller than+||| Assert to the totality checker that y is always structurally smaller than ||| x (which is typically a pattern argument) ||| @ x the larger value (typically a pattern argument) ||| @ y the smaller value (typically an argument to a recursive call) assert_smaller : (x : a) -> (y : b) -> b assert_smaller x y = y -||| Assert to the totality checker than the given expression will always+||| Assert to the totality checker that the given expression will always ||| terminate. assert_total : a -> a assert_total x = x
libs/prelude/Decidable/Equality.idr view
@@ -2,10 +2,11 @@ import Builtins import Prelude.Basics+import Prelude.Bool+import Prelude.Classes import Prelude.Either import Prelude.List-import Prelude.Vect-import Prelude.Fin+import Prelude.Nat import Prelude.Maybe --------------------------------------------------------------------------------@@ -49,13 +50,13 @@ -- Nat -------------------------------------------------------------------------------- -total OnotS : Z = S n -> Void-OnotS Refl impossible+total ZnotS : Z = S n -> Void+ZnotS Refl impossible instance DecEq Nat where decEq Z Z = Yes Refl- decEq Z (S _) = No OnotS- decEq (S _) Z = No (negEqSym OnotS)+ decEq Z (S _) = No ZnotS+ decEq (S _) Z = No (negEqSym ZnotS) decEq (S n) (S m) with (decEq n m) | Yes p = Yes $ cong p | No p = No $ \h : (S n = S m) => p $ succInjective n m h@@ -93,21 +94,6 @@ decEq (Right x') (Left y') = No $ negEqSym leftNotRight ----------------------------------------------------------------------------------- Fin-----------------------------------------------------------------------------------total FZNotFS : {f : Fin n} -> FZ {k = n} = FS f -> Void-FZNotFS Refl impossible--instance DecEq (Fin n) where- decEq FZ FZ = Yes Refl- decEq FZ (FS f) = No FZNotFS- decEq (FS f) FZ = No $ negEqSym FZNotFS- decEq (FS f) (FS f') with (decEq f f')- | Yes p = Yes $ cong p- | No p = No $ \h => p $ FSinjective {f = f} {f' = f'} h---------------------------------------------------------------------------------- -- Tuple -------------------------------------------------------------------------------- @@ -161,36 +147,6 @@ decEq (x :: xs) (y :: xs) | (No p) | (Yes Refl) = No (\eq => lemma_x_neq_xs_eq p Refl eq) decEq (x :: xs) (y :: ys) | (No p) | (No p') = No (\eq => lemma_x_neq_xs_neq p p' eq) ------------------------------------------------------------------------------------- Vect-----------------------------------------------------------------------------------total-vectInjective1 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> x = y-vectInjective1 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl--total-vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys-vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl--instance DecEq a => DecEq (Vect n a) where- decEq [] [] = Yes Refl- decEq (x :: xs) (y :: ys) with (decEq x y)- decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys)- decEq (x :: xs) (x :: xs) | Yes Refl | Yes Refl = Yes Refl- decEq (x :: xs) (x :: ys) | Yes Refl | No neq = No (neq . vectInjective2)- decEq (x :: xs) (y :: ys) | No neq = No (neq . vectInjective1)--{- The following definition is elaborated in a wrong case-tree. Examination pending.--instance DecEq a => DecEq (Vect n a) where- decEq [] [] = Yes Refl- decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)- decEq (x :: xs) (x :: xs) | (Yes Refl, Yes Refl) = Yes Refl- decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p))- decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p))--} -- For the primitives, we have to cheat because we don't have access to their -- internal implementations.
libs/prelude/IO.idr view
@@ -1,5 +1,6 @@ %unqualified +import Builtins import Prelude.List %access public
+ libs/prelude/Language/Reflection.idr view
@@ -0,0 +1,496 @@+module Language.Reflection++import Builtins+import Prelude.Applicative+import Prelude.Basics+import Prelude.Foldable+import Prelude.Functor+import Prelude.List+import Prelude.Nat+import Prelude.Traversable++%access public++data TTName =+ ||| A user-provided name+ UN String |+ ||| A name in some namespace.+ |||+ ||| The namespace is in reverse order, so `(NS (UN "foo") ["B", "A"])` represents the name `A.B.foo`+ NS TTName (List String) |+ ||| Machine-chosen names+ MN Int String |+ ||| Name of something which is never used in scope+ NErased+%name TTName n, n'++implicit+userSuppliedName : String -> TTName+userSuppliedName = UN++data TTUExp =+ ||| Universe variable+ UVar Int |+ ||| Explicit universe level+ UVal Int+%name TTUExp uexp++data NativeTy = IT8 | IT16 | IT32 | IT64++data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar+ | ITVec NativeTy Int++data ArithTy = ATInt Language.Reflection.IntTy | ATFloat++||| Primitive constants+data Const = I Int | BI Integer | Fl Float | Ch Char | Str String+ | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64+ | B8V Bits8x16 | B16V Bits16x8+ | B32V Bits32x4 | B64V Bits64x2+ | AType ArithTy | StrType+ | PtrType | ManagedPtrType | BufferType | VoidType | Forgot++%name Const c, c'++abstract class ReflConst (a : Type) where+ toConst : a -> Const++instance ReflConst Int where+ toConst x = I x++instance ReflConst Integer where+ toConst = BI++instance ReflConst Float where+ toConst = Fl++instance ReflConst Char where+ toConst = Ch++instance ReflConst String where+ toConst = Str++instance ReflConst Bits8 where+ toConst = B8++instance ReflConst Bits16 where+ toConst = B16++instance ReflConst Bits32 where+ toConst = B32++instance ReflConst Bits64 where+ toConst = B64++implicit+reflectConstant: (ReflConst a) => a -> Const+reflectConstant = toConst+++||| Types of named references+data NameType =+ ||| A reference which is just bound, e.g. by intro+ Bound |+ ||| A reference to a de Bruijn-indexed variable+ Ref |+ ||| Data constructor with tag and number+ DCon Int Int |+ ||| Type constructor with tag and number+ TCon Int Int++%name NameType nt, nt'++||| Types annotations for bound variables in different+||| binding contexts+data Binder a = Lam a+ | Pi a a+ | Let a a+ | NLet a a+ | Hole a+ | GHole a+ | Guess a a+ | PVar a+ | PVTy a+%name Binder b, b'++instance Functor Binder where+ map f (Lam x) = Lam (f x)+ map f (Pi x k) = Pi (f x) (f k)+ map f (Let x y) = Let (f x) (f y)+ map f (NLet x y) = NLet (f x) (f y)+ map f (Hole x) = Hole (f x)+ map f (GHole x) = GHole (f x)+ map f (Guess x y) = Guess (f x) (f y)+ map f (PVar x) = PVar (f x)+ map f (PVTy x) = PVTy (f x)++instance Foldable Binder where+ foldr f z (Lam x) = f x z+ foldr f z (Pi x k) = f x (f k z)+ foldr f z (Let x y) = f x (f y z)+ foldr f z (NLet x y) = f x (f y z)+ foldr f z (Hole x) = f x z+ foldr f z (GHole x) = f x z+ foldr f z (Guess x y) = f x (f y z)+ foldr f z (PVar x) = f x z+ foldr f z (PVTy x) = f x z++instance Traversable Binder where+ traverse f (Lam x) = [| Lam (f x) |]+ traverse f (Pi x k) = [| Pi (f x) (f k) |]+ traverse f (Let x y) = [| Let (f x) (f y) |]+ traverse f (NLet x y) = [| NLet (f x) (f y) |]+ traverse f (Hole x) = [| Hole (f x) |]+ traverse f (GHole x) = [| GHole (f x) |]+ traverse f (Guess x y) = [| Guess (f x) (f y) |]+ traverse f (PVar x) = [| PVar (f x) |]+ traverse f (PVTy x) = [| PVTy (f x) |]+++||| Reflection of the well typed core language+data TT =+ ||| A reference to some name (P for Parameter)+ P NameType TTName TT |+ ||| de Bruijn variables+ V Int |+ ||| Bind a variable+ Bind TTName (Binder TT) TT |+ ||| Apply one term to another+ App TT TT |+ ||| Embed a constant+ TConst Const |+ ||| Argument projection; runtime only+ Proj TT Int |+ ||| Erased terms+ Erased |+ ||| Impossible terms+ Impossible |+ ||| The type of types along (with universe constraints)+ TType TTUExp+%name TT tm, tm'++||| Raw terms without types+data Raw =+ ||| Variables, global or local+ Var TTName |+ ||| Bind a variable+ RBind TTName (Binder Raw) Raw |+ ||| Application+ RApp Raw Raw |+ ||| The type of types+ RType |+ RForce Raw |+ ||| Embed a constant+ RConstant Const+%name Raw tm, tm'++data SourceLocation : Type where+ FileLoc : (filename : String) -> (start : (Int, Int)) -> (end : (Int, Int)) -> SourceLocation++%name SourceLocation loc++||| Error reports are a list of report parts+data ErrorReportPart =+ ||| A human-readable string+ TextPart String |+ ||| An Idris name (to be semantically coloured)+ NamePart TTName |+ ||| An Idris term, to be pretty printed+ TermPart TT |+ ||| An indented sub-report, to provide more details+ SubReport (List ErrorReportPart)+%name ErrorReportPart part, p++||| A representation of Idris's tactics that can be returned from custom+||| tactic implementations. Generate these using `applyTactic`.+data Tactic =+ ||| Try the first tactic and resort to the second one on failure+ Try Tactic Tactic |+ ||| Only run if the goal has the right type+ GoalType String Tactic |+ ||| Resolve function name, find matching arguments in the+ ||| context and compute the proof target+ Refine TTName |+ ||| Apply both tactics in sequence+ Seq Tactic Tactic |+ ||| Intelligently construct the proof target from the context+ Trivial |+ ||| Build a proof by applying contructors up to a maximum depth+ Search Int |+ ||| Resolve a type class+ Instance |+ ||| Infer the proof target from the context+ Solve |+ ||| introduce all variables into the context+ Intros |+ ||| Introduce a named variable into the context, use the+ ||| first one if the given name is not found+ Intro TTName |+ ||| Invoke the reflected rep. of another tactic+ ApplyTactic TT |+ ||| Turn a value into its reflected representation+ Reflect TT |+ ||| Use a `%reflection` function+ ByReflection TT |+ ||| Turn a raw value back into a term+ Fill Raw |+ ||| Use the given value to conclude the proof+ Exact TT |+ ||| Focus on a particular hole+ Focus TTName |+ ||| Rewrite with an equality+ Rewrite TT |+ ||| Perform induction on a particular expression+ Induction TT |+ ||| Perform case analysis on a particular expression+ Case TT |+ ||| Name a reflected term+ LetTac TTName TT |+ ||| Name a reflected term and type it+ LetTacTy TTName TT TT |+ ||| Normalise the goal+ Compute |+ ||| Do nothing+ Skip |+ ||| Fail with an error message+ Fail (List ErrorReportPart) |+ ||| Attempt to fill the hole with source code information+ SourceFC+%name Tactic tac, tac'+++||| Things with a canonical representation in the TT datatype.+|||+||| 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+ ||| A representation of the type `a`.+ |||+ ||| This is to enable quoting polymorphic datatypes+ quotedTy : TT++ ||| Quote a particular element of `a`.+ |||+ ||| Each equation should look something like ```quote (Foo x y) = `(Foo ~(quote x) ~(quote y))```+ quote : a -> TT++instance Quotable Nat where+ quotedTy = `(Nat)++ quote Z = `(Z)+ quote (S k) = `(S ~(quote k))++instance Quotable Int where+ quotedTy = `(Int)+ quote x = TConst (I x)++instance Quotable Float where+ quotedTy = `(Float)+ quote x = TConst (Fl x)++instance Quotable Char where+ quotedTy = `(Char)+ quote x = TConst (Ch x)++instance Quotable Bits8 where+ quotedTy = `(Bits8)+ quote x = TConst (B8 x)++instance Quotable Bits16 where+ quotedTy = `(Bits16)+ quote x = TConst (B16 x)++instance Quotable Bits32 where+ quotedTy = `(Bits32)+ quote x = TConst (B32 x)++instance Quotable Bits64 where+ quotedTy = `(Bits64)+ quote x = TConst (B64 x)++instance Quotable Integer where+ quotedTy = `(Integer)+ quote x = TConst (BI x)++instance Quotable Bits8x16 where+ quotedTy = `(Bits8x16)+ quote x = TConst (B8V x)++instance Quotable Bits16x8 where+ quotedTy = `(Bits16x8)+ quote x = TConst (B16V x)++instance Quotable Bits32x4 where+ quotedTy = `(Bits32x4)+ quote x = TConst (B32V x)++instance Quotable Bits64x2 where+ quotedTy = `(Bits64x2)+ quote x = TConst (B64V x)++instance Quotable String where+ quotedTy = `(String)+ quote x = TConst (Str x)++instance Quotable NameType 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 TTName 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+ quotedTy = `(NativeTy)+ quote IT8 = `(Reflection.IT8)+ quote IT16 = `(Reflection.IT16)+ quote IT32 = `(Reflection.IT32)+ quote IT64 = `(Reflection.IT64)++instance Quotable Reflection.IntTy where+ quotedTy = `(Reflection.IntTy)+ quote (ITFixed x) = `(ITFixed ~(quote x))+ quote ITNative = `(Reflection.ITNative)+ quote ITBig = `(ITBig)+ quote ITChar = `(Reflection.ITChar)+ quote (ITVec x y) = `(ITVec ~(quote x) ~(quote y))++instance Quotable ArithTy where+ quotedTy = `(ArithTy)+ quote (ATInt x) = `(ATInt ~(quote x))+ quote ATFloat = `(ATFloat)++instance Quotable Const where+ quotedTy = `(Const)+ quote (I x) = `(I ~(quote x))+ quote (BI x) = `(BI ~(quote x))+ quote (Fl x) = `(Fl ~(quote x))+ quote (Ch x) = `(Ch ~(quote x))+ quote (Str x) = `(Str ~(quote x))+ quote (B8 x) = `(B8 ~(quote x))+ quote (B16 x) = `(B16 ~(quote x))+ quote (B32 x) = `(B32 ~(quote x))+ quote (B64 x) = `(B64 ~(quote x))+ quote (B8V xs) = `(B8V ~(quote xs))+ quote (B16V xs) = `(B16V ~(quote xs))+ quote (B32V xs) = `(B32V ~(quote xs))+ quote (B64V xs) = `(B64V ~(quote xs))+ quote (AType x) = `(AType ~(quote x))+ quote StrType = `(StrType)+ quote PtrType = `(PtrType)+ quote ManagedPtrType = `(ManagedPtrType)+ quote BufferType = `(BufferType)+ quote VoidType = `(VoidType)+ quote Forgot = `(Forgot)+++instance Quotable TTUExp where+ quotedTy = `(TTUExp)+ quote (UVar x) = `(UVar ~(quote x))+ quote (UVal x) = `(UVal ~(quote x))++mutual+ instance Quotable TT where+ quotedTy = `(TT)+ quote (P nt n tm) = `(P ~(quote nt) ~(quote n) ~(quote tm))+ quote (V x) = `(V ~(quote x))+ quote (Bind n b tm) = `(Bind ~(quote n) ~(assert_total (quote b)) ~(quote tm))+ quote (App f x) = `(App ~(quote f) ~(quote x))+ quote (TConst c) = `(TConst ~(quote c))+ quote (Proj tm x) = `(Proj ~(quote tm) ~(quote x))+ quote Erased = `(Erased)+ quote Impossible = `(Impossible)+ quote (TType uexp) = `(TType ~(quote uexp))++ instance Quotable (Binder 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))+ ~(assert_total (quote k)))+ quote (Let x y) = `(Let {a=TT} ~(assert_total (quote x))+ ~(assert_total (quote y)))+ quote (NLet x y) = `(NLet {a=TT} ~(assert_total (quote x))+ ~(assert_total (quote y)))+ quote (Hole x) = `(Hole {a=TT} ~(assert_total (quote x)))+ quote (GHole x) = `(GHole {a=TT} ~(assert_total (quote x)))+ quote (Guess x y) = `(Guess {a=TT} ~(assert_total (quote x))+ ~(assert_total (quote y)))+ quote (PVar x) = `(PVar {a=TT} ~(assert_total (quote x)))+ quote (PVTy x) = `(PVTy {a=TT} ~(assert_total (quote x)))+++instance Quotable ErrorReportPart where+ quotedTy = `(ErrorReportPart)+ quote (TextPart x) = `(TextPart ~(quote x))+ quote (NamePart n) = `(NamePart ~(quote n))+ quote (TermPart tm) = `(TermPart ~(quote tm))+ quote (SubReport xs) = `(SubReport ~(assert_total $ quote xs))++mutual+ quoteRaw : Raw -> TT+ quoteRaw (Var n) = `(Var ~(quote n))+ 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 (RForce tm) = `(RForce ~(quoteRaw tm))+ quoteRaw (RConstant c) = `(RConstant ~(quote c))++ quoteRawBinder : Binder Raw -> TT+ quoteRawBinder (Lam x) = `(Lam {a=Raw} ~(quoteRaw x))+ quoteRawBinder (Pi x k) = `(Pi {a=Raw} ~(quoteRaw x) ~(quoteRaw k))+ quoteRawBinder (Let x y) = `(Let {a=Raw} ~(quoteRaw x) ~(quoteRaw y))+ quoteRawBinder (NLet x y) = `(NLet {a=Raw} ~(quoteRaw x) ~(quoteRaw y))+ quoteRawBinder (Hole x) = `(Hole {a=Raw} ~(quoteRaw x))+ quoteRawBinder (GHole x) = `(GHole {a=Raw} ~(quoteRaw x))+ quoteRawBinder (Guess x y) = `(Guess {a=Raw} ~(quoteRaw x) ~(quoteRaw y))+ quoteRawBinder (PVar x) = `(PVar {a=Raw} ~(quoteRaw x))+ quoteRawBinder (PVTy x) = `(PVTy {a=Raw} ~(quoteRaw x))++instance Quotable Raw where+ quotedTy = `(Raw)+ quote = quoteRaw++instance Quotable (Binder Raw) where+ quotedTy = `(Binder Raw)+ quote = quoteRawBinder++instance Quotable Tactic 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 (Seq tac tac') = `(Seq ~(quote tac) ~(quote tac'))+ quote Trivial = `(Trivial)+ quote (Search x) = `(Search ~(quote x))+ quote Instance = `(Instance)+ quote Solve = `(Solve)+ quote Intros = `(Intros)+ quote (Intro n) = `(Intro ~(quote n))+ quote (ApplyTactic tm) = `(ApplyTactic ~(quote tm))+ quote (Reflect tm) = `(Reflect ~(quote tm))+ quote (ByReflection tm) = `(ByReflection ~(quote tm))+ quote (Fill tm) = `(Fill ~(quote tm))+ quote (Exact tm) = `(Exact ~(quote tm))+ quote (Focus n) = `(Focus ~(quote n))+ quote (Rewrite tm) = `(Rewrite ~(quote tm))+ quote (Induction tm) = `(Induction ~(quote tm))+ quote (Case tm) = `(Case ~(quote tm))+ quote (LetTac n tm) = `(LetTac ~(quote n) ~(quote tm))+ quote (LetTacTy n tm tm') = `(LetTacTy ~(quote n) ~(quote tm) ~(quote tm'))+ quote Compute = `(Compute)+ quote Skip = `(Skip)+ quote (Fail xs) = `(Fail ~(quote xs))+ quote SourceFC = `(SourceFC)
+ libs/prelude/Language/Reflection/Errors.idr view
@@ -0,0 +1,48 @@+module Language.Reflection.Errors++import Builtins++import Language.Reflection++import Prelude.Bool+import Prelude.List+import Prelude.Maybe++data Err = Msg String+ | InternalMsg String+ | CantUnify Bool TT TT Err (List (TTName, TT)) Int+ -- Int is 'score' - how much we did unify+ -- Bool indicates recoverability, True indicates more info may make+ -- unification succeed+ | InfiniteUnify TTName TT (List (TTName, TT))+ | CantConvert TT TT (List (TTName, TT))+ | CantSolveGoal TT (List (TTName, TT))+ | UnifyScope TTName TTName TT (List (TTName, TT))+ | CantInferType String+ | NonFunctionType TT TT+ | NotEquality TT TT+ | TooManyArguments TTName+ | CantIntroduce TT+ | NoSuchVariable TTName+ | WithFnType TT+ | CantMatch TT+ | NoTypeDecl TTName+ | NotInjective TT TT TT+ | CantResolve TT+ | CantResolveAlts (List String)+ | IncompleteTerm TT+ | UniverseError+ | ProgramLineComment+ | Inaccessible TTName+ | NonCollapsiblePostulate TTName+ | AlreadyDefined TTName+ | ProofSearchFail Err+ | NoRewriting TT+ | ProviderError String+ | LoadingFailed String Err++%name Err err, e++-- Error reports become functions in List (String, TT) -> Err -> ErrorReport+ErrorHandler : Type+ErrorHandler = Err -> Maybe (List ErrorReportPart)
libs/prelude/Prelude.idr view
@@ -1,29 +1,32 @@ module Prelude -import Builtins-import IO+import public Builtins+import public IO -import Prelude.Bool-import Prelude.Classes-import Prelude.Cast-import Prelude.Nat-import Prelude.Fin-import Prelude.List-import Prelude.Maybe-import Prelude.Monad-import Prelude.Applicative-import Prelude.Functor-import Prelude.Either-import Prelude.Vect-import Prelude.Strings-import Prelude.Chars-import Prelude.Traversable-import Prelude.Bits-import Prelude.Stream-import Prelude.Uninhabited-import Prelude.Pairs+import public Prelude.Algebra+import public Prelude.Basics+import public Prelude.Bool+import public Prelude.Classes+import public Prelude.Cast+import public Prelude.Nat+import public Prelude.List+import public Prelude.Maybe+import public Prelude.Monad+import public Prelude.Applicative+import public Prelude.Foldable+import public Prelude.Functor+import public Prelude.Either+import public Prelude.Strings+import public Prelude.Chars+import public Prelude.Traversable+import public Prelude.Bits+import public Prelude.Uninhabited+import public Prelude.Pairs+import public Prelude.Stream -import Decidable.Equality+import public Decidable.Equality+import public Language.Reflection+import public Language.Reflection.Errors %access public %default total@@ -42,11 +45,6 @@ instance Show Float where show = prim__floatToStr -asciiTab : Vect 32 String-asciiTab = ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",- "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",- "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",- "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US"] firstCharIs : (Char -> Bool) -> String -> Bool firstCharIs p s with (strM s)@@ -67,12 +65,22 @@ showLitChar '\SO' = protectEsc (== 'H') "\\SO" showLitChar '\DEL' = ("\\DEL" ++) showLitChar '\\' = ("\\\\" ++)-showLitChar c = case (integerToFin (cast (cast {to=Int} c)) 32) of- Just k => strCons '\\' . ((index k asciiTab) ++)+showLitChar c = case getAt (cast (cast {to=Int} c)) asciiTab of+ Just k => strCons '\\' . (k ++) Nothing => if (c > '\DEL') then strCons '\\' . protectEsc isDigit (show (cast {to=Int} c)) else strCons c+ where asciiTab : List String+ asciiTab = ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",+ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",+ "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",+ "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US"] + getAt : Nat -> List String -> Maybe String+ getAt Z (x :: xs) = Just x+ getAt (S k) (x :: xs) = getAt k xs+ getAt _ [] = Nothing+ showLitString : List Char -> String -> String showLitString [] = id showLitString ('"'::cs) = ("\\\"" ++) . showLitString cs@@ -216,13 +224,6 @@ show' acc [x] = acc ++ show x show' acc (x :: xs) = show' (acc ++ show x ++ ", ") xs -instance Show a => Show (Vect n a) where- show xs = "[" ++ show' xs ++ "]" where- show' : Vect n a -> String- show' [] = ""- show' [x] = show x- show' (x :: xs) = show x ++ ", " ++ show' xs- instance Show a => Show (Maybe a) where show Nothing = "Nothing" show (Just x) = "Just " ++ show x@@ -274,15 +275,6 @@ fs <$> vs = concatMap (\f => map f vs) fs -instance Applicative (Vect k) where- pure = replicate _-- fs <$> vs = zipWith apply fs vs--instance Applicative Stream where- pure = repeat- (<$>) = zipWith apply- ---- Alternative instances instance Alternative Maybe where@@ -315,12 +307,6 @@ instance Monad List where m >>= f = concatMap f m -instance Monad (Vect n) where- m >>= f = diag (map f m)--instance Monad Stream where- s >>= f = diag (map f s)- ---- Traversable instances instance Traversable Maybe where@@ -331,10 +317,6 @@ traverse f [] = pure List.Nil traverse f (x::xs) = [| List.(::) (f x) (traverse f xs) |] -instance Traversable (Vect n) where- traverse f [] = pure Vect.Nil- traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |]- ---- some mathematical operations ---- XXX this should probably go some place else, pow : (Num a) => a -> Nat -> a@@ -418,17 +400,6 @@ where go : List Nat -> List Int go [] = [] go (x :: xs) = n + (cast x * inc) :: go xs--instance Enum (Fin (S n)) where- pred FZ = FZ- pred (FS n) = weaken n- succ n = case strengthen (FS n) of- Left _ => last- Right k => k- toNat n = cast n- fromNat {n=n} m = case natToFin m (S n) of- Just k => k- Nothing => last syntax "[" [start] ".." [end] "]" = enumFromTo start end
libs/prelude/Prelude/Algebra.idr view
@@ -6,6 +6,7 @@ infixl 6 <-> infixl 6 <+> infixl 6 <*>+infixl 5 <#> %access public @@ -298,25 +299,31 @@ total fieldInverseIsInverseL : (l : a) -> l <*> inverseM l = unity total fieldInverseIsInverseR : (r : a) -> inverseM r <*> r = unity --- vector spaces.-||| A Vector Space over a Field can be considered as an additive Abeliean Group-||| of Vectors adjoined to the Field structure by distributivity laws relating-||| the two operations. Such that we satisfy the following laws:+||| 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: |||-||| + Unity for `<*>`:-||| forall a, a <*> unity == a-||| forall a, unity <*> a == a-||| + Distributivity of `<*>` and `<+>`:-||| forall a x y, a <*> (x <+> y) == (a <*> x) <+> (a <*> y)-||| forall a b x, (a <+> b) <*> x == (a <*> x) <+> (b <*> x)-class (Field a, AbelianGroup a) => VectorSpace a a where {}+||| + 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 (VerifiedField a, VerifiedAbelianGroup a, VectorSpace a a) => VerifiedVectorSpace a a where- total vectorspaceScalarUnityIsUnityL : (l : a) -> l <*> unity = l- total vectorspaceScalarUnityIsUnityR : (r : a) -> unity <*> r = r- total vectorspaceScalarIsDistributiveWRTVectorAddition : (s : a) -> (x, y : a) -> s <*> (x <+> y) = (s <*> x) <+> (s <*> y)- total vectorspaceScalarIsDistributiveWRTFieldAddition : (s, t : a) -> (x : a) -> (s <+> t) <*> x = (s <*> x) <+> (t <*> x)+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.
libs/prelude/Prelude/Applicative.idr view
@@ -1,7 +1,9 @@ module Prelude.Applicative import Builtins+ import Prelude.Basics+import Prelude.Bool import Prelude.Classes import Prelude.Functor @@ -16,6 +18,17 @@ 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 infixl 2 <$ (<$) : Applicative f => f a -> f b -> f a
libs/prelude/Prelude/Basics.idr view
@@ -30,7 +30,7 @@ infixl 9 . ||| Function composition-(.) : {a, b, c : Type*} -> (b -> c) -> (a -> b) -> a -> c+(.) : (b -> c) -> (a -> b) -> a -> c (.) f g x = f (g x) ||| Takes in the first two arguments in reverse order.
libs/prelude/Prelude/Bits.idr view
@@ -1,12 +1,18 @@ module Prelude.Bits -import Prelude.Strings-import Prelude.Vect+import Builtins++import Prelude.Basics import Prelude.Bool+import Prelude.Cast+import Prelude.Classes+import Prelude.Foldable+import Prelude.Nat+import Prelude.List+import Prelude.Strings %access public %default total- b8ToString : Bits8 -> String b8ToString c = pack (with List [c1, c2])
libs/prelude/Prelude/Bool.idr view
@@ -15,21 +15,6 @@ boolElim True t e = t boolElim False t e = e -||| Ensure that some run-time Boolean test has been performed.-|||-||| This lifts a Boolean predicate to the type level. See the function `choose`-||| if you need to perform a Boolean test and convince the type checker of this-||| fact.-|||-||| If you find yourself using `So` for something other than primitive types,-||| it may be appropriate to define a type of evidence for the property that you-||| care about instead.-data So : Bool -> Type where - Oh : So True--instance Uninhabited (So False) where- uninhabited Oh impossible- -- Syntactic sugar for boolean elimination. syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e)
libs/prelude/Prelude/Classes.idr view
@@ -57,7 +57,7 @@ -- ---------------------------------------------------------- [ Ordering Class ]-data Ordering = LT | EQ | GT+%elim data Ordering = LT | EQ | GT instance Eq Ordering where LT == LT = True
libs/prelude/Prelude/Either.idr view
@@ -2,11 +2,14 @@ import Builtins +import Prelude.Basics+import Prelude.Bool+import Prelude.Classes import Prelude.Maybe import Prelude.List ||| A sum type-data Either a b =+%elim data Either a b = ||| One possibility of the sum, conventionally used to represent errors Left a | ||| The other possibility, conventionally used to represent success@@ -29,11 +32,6 @@ -------------------------------------------------------------------------------- -- Misc. ----------------------------------------------------------------------------------||| Perform a case analysis on a Boolean, providing clients with a `So` proof-choose : (b : Bool) -> Either (So b) (So (not b))-choose True = Left Oh-choose False = Right Oh ||| Simply-typed eliminator for Either ||| @ f the action to take on Left
− libs/prelude/Prelude/Fin.idr
@@ -1,152 +0,0 @@-module Prelude.Fin--import Prelude.Nat-import Prelude.Either-import Prelude.Uninhabited--%default total--||| Numbers strictly less than some bound. The name comes from "finite sets".-|||-||| It's probably not a good idea to use `Fin` for arithmetic, and they will be-||| exceedingly inefficient at run time.-||| @ n the upper bound-data Fin : (n : Nat) -> Type where- FZ : Fin (S k)- FS : Fin k -> Fin (S k)--instance Uninhabited (Fin Z) where- uninhabited FZ impossible- uninhabited (FS f) impossible--FSInjective : (m : Fin k) -> (n : Fin k) -> FS m = FS n -> m = n-FSInjective left _ Refl = Refl--instance Eq (Fin n) where- (==) FZ FZ = True- (==) (FS k) (FS k') = k == k'- (==) _ _ = False--||| There are no elements of `Fin Z`-FinZAbsurd : Fin Z -> Void-FinZAbsurd FZ impossible--FinZElim : Fin Z -> a-FinZElim x = void (FinZAbsurd x)--||| Convert a Fin to a Nat-finToNat : Fin n -> Nat-finToNat FZ = Z-finToNat (FS k) = S (finToNat k)--||| `finToNat` is injective-finToNatInjective : (fm : Fin k) -> (fn : Fin k) -> (finToNat fm) = (finToNat fn) -> fm = fn-finToNatInjective FZ FZ Refl = Refl-finToNatInjective (FS m) FZ Refl impossible-finToNatInjective FZ (FS n) Refl impossible-finToNatInjective (FS m) (FS n) prf =- cong (finToNatInjective m n (succInjective (finToNat m) (finToNat n) prf)) --instance Cast (Fin n) Nat where- cast x = finToNat x--||| Convert a Fin to an Integer-finToInteger : Fin n -> Integer-finToInteger FZ = 0-finToInteger (FS k) = 1 + finToInteger k--instance Cast (Fin n) Integer where- cast x = finToInteger x--||| Weaken the bound on a Fin by 1-weaken : Fin n -> Fin (S n)-weaken FZ = FZ-weaken (FS k) = FS (weaken k)--||| Weaken the bound on a Fin by some amount-weakenN : (n : Nat) -> Fin m -> Fin (m + n)-weakenN n FZ = FZ-weakenN n (FS f) = FS (weakenN n f)--||| Attempt to tighten the bound on a Fin.-||| Return `Left` if the bound could not be tightened, or `Right` if it could.-strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n)-strengthen {n = S k} FZ = Right FZ-strengthen {n = S k} (FS i) with (strengthen i)- strengthen (FS k) | Left x = Left (FS x)- strengthen (FS k) | Right x = Right (FS x)-strengthen f = Left f--||| Add some natural number to a Fin, extending the bound accordingly-||| @ n the previous bound-||| @ m the number to increase the Fin by-shift : (m : Nat) -> Fin n -> Fin (m + n)-shift Z f = f-shift {n=n} (S m) f = FS {k = (m + n)} (shift m f)--||| The largest element of some Fin type-last : Fin (S n)-last {n=Z} = FZ-last {n=S _} = FS last--total FSinjective : {f : Fin n} -> {f' : Fin n} -> (FS f = FS f') -> f = f'-FSinjective Refl = Refl--instance Ord (Fin n) where- compare FZ FZ = EQ- compare FZ (FS _) = LT- compare (FS _) FZ = GT- compare (FS x) (FS y) = compare x y- -instance MinBound (Fin (S n)) where- minBound = FZ--instance MaxBound (Fin (S n)) where- maxBound = last---||| Add two Fins, extending the bound-(+) : Fin n -> Fin m -> Fin (n + m)-(+) {n=S n} {m=m} FZ f' = rewrite plusCommutative n m in weaken (weakenN n f')-(+) (FS f) f' = FS (f + f')--||| Substract two Fins, keeping the bound of the minuend-(-) : Fin n -> Fin m -> Fin n-FZ - _ = FZ-f - FZ = f-(FS f) - (FS f') = weaken $ f - f'--||| Multiply two Fins, extending the bound-(*) : Fin n -> Fin m -> Fin (n * m)-(*) {n=Z} f f' = FinZElim f-(*) {m=Z} f f' = FinZElim f'-(*) {n=S n} {m=S m} FZ f' = FZ-(*) {n=S n} {m=S m} (FS f) f' = f' + (f * f')---- Construct a Fin from an integer literal which must fit in the given Fin--natToFin : Nat -> (n : Nat) -> Maybe (Fin n)-natToFin Z (S j) = Just FZ-natToFin (S k) (S j) with (natToFin k j)- | Just k' = Just (FS k')- | Nothing = Nothing-natToFin _ _ = Nothing--integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)-integerToFin x Z = Nothing -- make sure 'n' is concrete, to save reduction!-integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing--||| Proof that some `Maybe` is actually `Just`-data IsJust : Maybe a -> Type where- ItIsJust : IsJust (Just x)--||| Allow overloading of Integer literals for Fin.-||| @ x the Integer that the user typed-||| @ prf an automatically-constructed proof that `x` is in bounds-fromInteger : (x : Integer) ->- {default ItIsJust- prf : (IsJust (integerToFin x n))} ->- Fin n-fromInteger {n} x {prf} with (integerToFin x n)- fromInteger {n} x {prf = ItIsJust} | Just y = y-
libs/prelude/Prelude/Foldable.idr view
@@ -2,6 +2,7 @@ import Builtins import Prelude.Bool+import Prelude.Basics import Prelude.Classes import Prelude.Algebra
libs/prelude/Prelude/Functor.idr view
@@ -10,5 +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+ instance Functor id where map f a = f a
libs/prelude/Prelude/List.idr view
@@ -4,6 +4,8 @@ import Prelude.Algebra import Prelude.Basics+import Prelude.Bool+import Prelude.Classes import Prelude.Foldable import Prelude.Functor import Prelude.Maybe@@ -232,10 +234,6 @@ instance Monoid (List a) where neutral = [] --- XXX: unification failure--- instance VerifiedSemigroup (List a) where--- semigroupOpIsAssociative = appendAssociative- instance Functor List where map f [] = [] map f (x::xs) = f x :: map f xs@@ -810,6 +808,13 @@ ||| No list contains an element of the empty list. 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/Maybe.idr view
@@ -2,7 +2,10 @@ import Builtins import Prelude.Algebra+import Prelude.Basics+import Prelude.Bool import Prelude.Cast+import Prelude.Classes import Prelude.Foldable %access public@@ -23,6 +26,10 @@ isJust : Maybe a -> Bool isJust Nothing = False isJust (Just j) = True++||| Proof that some `Maybe` is actually `Just`+data IsJust : Maybe a -> Type where+ ItIsJust : IsJust (Just x) -------------------------------------------------------------------------------- -- Misc
libs/prelude/Prelude/Monad.idr view
@@ -14,6 +14,16 @@ 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
libs/prelude/Prelude/Nat.idr view
@@ -3,6 +3,7 @@ import Builtins import Prelude.Algebra+import Prelude.Basics import Prelude.Bool import Prelude.Cast import Prelude.Classes
libs/prelude/Prelude/Stream.idr view
@@ -1,7 +1,13 @@ module Prelude.Stream +import Builtins++import Prelude.Basics import Prelude.Functor-import Prelude.Vect+import Prelude.Applicative+import Prelude.Monad+import Prelude.Nat+import Prelude.List %access public %default total@@ -27,7 +33,7 @@ ||| Take precisely n elements from the stream ||| @ n how many elements to take ||| @ xs the stream-take : (n : Nat) -> (xs : Stream a) -> Vect n a+take : (n : Nat) -> (xs : Stream a) -> List a take Z _ = [] take (S n) (x :: xs) = x :: (take n xs) @@ -103,11 +109,10 @@ scanr : (f : a -> Inf b -> b) -> (xs : Stream a) -> Stream b scanr f (x :: xs) = f x (foldr f xs) :: scanr f xs -||| Produce a Stream repeating a sequence-||| @ xs the sequence to repeat-cycle : (xs : Vect (S n) a) -> Stream a-cycle xs = cycle_ xs xs- where cycle_ : Vect (S n) a -> Vect m a -> Stream a- cycle_ (x :: xs) [] = x :: cycle_ (x :: xs) xs- cycle_ xs (x :: ys) = x :: cycle_ xs ys+instance Applicative Stream where+ pure = repeat+ (<$>) = zipWith apply++instance Monad Stream where+ s >>= f = diag (map f s)
libs/prelude/Prelude/Strings.idr view
@@ -1,11 +1,19 @@ module Prelude.Strings import Builtins-import Prelude.List++import Prelude.Algebra+import Prelude.Basics+import Prelude.Bool import Prelude.Chars import Prelude.Cast+import Prelude.Classes import Prelude.Either import Prelude.Foldable+import Prelude.Functor+import Prelude.List+import Prelude.Nat+import Decidable.Equality ||| Appends two strings together. |||@@ -74,20 +82,20 @@ StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs) ||| Version of 'strHead' that statically verifies that the string is not empty.-strHead' : (x : String) -> So (not (x == "")) -> Char+strHead' : (x : String) -> (not (x == "") = True) -> Char strHead' x p = assert_total $ prim__strHead x ||| Version of 'strTail' that statically verifies that the string is not empty.-strTail' : (x : String) -> So (not (x == "")) -> String+strTail' : (x : String) -> (not (x == "") = True) -> String strTail' x p = assert_total $ prim__strTail x -- we need the 'believe_me' because the operations are primitives strM : (x : String) -> StrM x-strM x with (choose (not (x == "")))- strM x | (Left p) = really_believe_me $ +strM x with (decEq (not (x == "")) True)+ strM x | (Yes p) = really_believe_me $ StrCons (assert_total (strHead' x p)) (assert_total (strTail' x p))- strM x | (Right p) = really_believe_me StrNil+ strM x | (No p) = really_believe_me StrNil -- annoyingly, we need these assert_totals because StrCons doesn't have -- a recursive argument, therefore the termination checker doesn't believe
libs/prelude/Prelude/Traversable.idr view
@@ -1,7 +1,11 @@ module Prelude.Traversable +import Builtins++import Prelude.Basics import Prelude.Applicative import Prelude.Foldable+import Prelude.Functor traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ f = foldr (($>) . f) (pure ())
libs/prelude/Prelude/Uninhabited.idr view
@@ -1,3 +1,6 @@+||| Utilities for working with uninhabited types, to record explicit+||| locations for canonical proofs of emptiness. Typically, one should+||| use the `absurd` function. module Prelude.Uninhabited import Builtins
− libs/prelude/Prelude/Vect.idr
@@ -1,548 +0,0 @@-module Prelude.Vect--import Prelude.Fin-import Prelude.Foldable-import Prelude.Functor-import Prelude.List-import Prelude.Classes-import Prelude.Nat-import Prelude.Bool-import Prelude.Uninhabited--%access public-%default total--infixr 7 ::--%elim data Vect : Nat -> Type -> Type where- Nil : Vect Z a- (::) : (x : a) -> (xs : Vect n a) -> Vect (S n) a---- Hints for interactive editing-%name Vect xs,ys,zs,ws------------------------------------------------------------------------------------- Length-----------------------------------------------------------------------------------||| Calculate the length of a `Vect`.-|||-||| **Note**: this is only useful if you don't already statically know the length-||| and you want to avoid matching the implicit argument for erasure reasons.-||| @ n the length (provably equal to the return value)-||| @ xs the vector-length : (xs : Vect n a) -> Nat-length [] = 0-length (x::xs) = 1 + length xs--||| Show that the length function on vectors in fact calculates the length-private lengthCorrect : (n : Nat) -> (xs : Vect n a) -> length xs = n-lengthCorrect Z [] = Refl-lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in Refl------------------------------------------------------------------------------------- Indexing into vectors-----------------------------------------------------------------------------------||| All but the first element of the vector-tail : Vect (S n) a -> Vect n a-tail (x::xs) = xs--||| Only the first element of the vector-head : Vect (S n) a -> a-head (x::xs) = x--||| The last element of the vector-last : Vect (S n) a -> a-last (x::[]) = x-last (x::y::ys) = last $ y::ys--||| All but the last element of the vector-init : Vect (S n) a -> Vect n a-init (x::[]) = []-init (x::y::ys) = x :: init (y::ys)--||| Extract a particular element from a vector-index : Fin n -> Vect n a -> a-index FZ (x::xs) = x-index (FS k) (x::xs) = index k xs-index FZ [] impossible---||| Insert an element at a particular index-insertAt : Fin (S n) -> a -> Vect n a -> Vect (S n) a-insertAt FZ y xs = y :: xs-insertAt (FS k) y (x::xs) = x :: insertAt k y xs-insertAt (FS k) y [] = absurd k--||| Construct a new vector consisting of all but the indicated element-deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a-deleteAt FZ (x::xs) = xs-deleteAt {n = S m} (FS k) (x::xs) = x :: deleteAt k xs-deleteAt {n = Z} (FS k) (x::xs) = absurd k-deleteAt _ [] impossible--||| Replace an element at a particlar index with another-replaceAt : Fin n -> t -> Vect n t -> Vect n t-replaceAt FZ y (x::xs) = y :: xs-replaceAt (FS k) y (x::xs) = x :: replaceAt k y xs--||| Replace the element at a particular index with the result of applying a function to it-||| @ i the index to replace at-||| @ f the update function-||| @ xs the vector to replace in-updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t-updateAt FZ f (x::xs) = f x :: xs-updateAt (FS k) f (x::xs) = x :: updateAt k f xs------------------------------------------------------------------------------------- Subvectors-----------------------------------------------------------------------------------||| Get the first m elements of a Vect-||| @ m the number of elements to take-take : (n : Nat) -> Vect (n + m) a -> Vect n a-take Z xs = []-take (S k) (x :: xs) = x :: take k xs--||| Remove the first m elements of a Vect-||| @ m the number of elements to remove-drop : (n : Nat) -> Vect (n + m) a -> Vect m a-drop Z xs = xs-drop (S k) (x :: xs) = drop k xs--||| Take the longest prefix of a Vect such that all elements satisfy some-||| Boolean predicate.-|||-||| @ p the predicate-takeWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a)-takeWhile p [] = (_ ** [])-takeWhile p (x::xs) =- let (len ** ys) = takeWhile p xs- in if p x then- (S len ** x :: ys)- else- (_ ** [])--||| Remove the longest prefix of a Vect such that all removed elements satisfy some-||| Boolean predicate.-|||-||| @ p the predicate-dropWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a)-dropWhile p [] = (_ ** [])-dropWhile p (x::xs) =- if p x then- dropWhile p xs- else- (_ ** x::xs)------------------------------------------------------------------------------------- Transformations-----------------------------------------------------------------------------------||| Reverse the order of the elements of a vector-reverse : Vect n a -> Vect n a-reverse xs = go [] xs- where go : Vect n a -> Vect m a -> Vect (n+m) a- go {n} acc [] = rewrite plusZeroRightNeutral n in acc- go {n} {m=S m} acc (x :: xs) = rewrite sym $ plusSuccRightSucc n m- in go (x::acc) xs--||| Alternate an element between the other elements of a vector-||| @ sep the element to intersperse-||| @ xs the vector to separate with `sep`-intersperse : (sep : a) -> (xs : Vect n a) -> Vect (n + pred n) a-intersperse sep [] = []-intersperse sep (x::xs) = x :: intersperse' sep xs- where- intersperse' : a -> Vect n a -> Vect (n + n) a- intersperse' sep [] = []- intersperse' {n=S n} sep (x::xs) = rewrite sym $ plusSuccRightSucc n n- in sep :: x :: intersperse' sep xs------------------------------------------------------------------------------------- Conversion from list (toList is provided by Foldable)------------------------------------------------------------------------------------fromList' : Vect n a -> (l : List a) -> Vect (length l + n) a-fromList' ys [] = ys-fromList' {n} ys (x::xs) =- rewrite (plusSuccRightSucc (length xs) n) ==>- Vect (plus (length xs) (S n)) a in- fromList' (x::ys) xs--||| Convert a list to a vector.-|||-||| The length of the list should be statically known.-fromList : (l : List a) -> Vect (length l) a-fromList l =- rewrite (sym $ plusZeroRightNeutral (length l)) in- reverse $ fromList' [] l------------------------------------------------------------------------------------- Building (bigger) vectors-----------------------------------------------------------------------------------||| Append two vectors-(++) : Vect m a -> Vect n a -> Vect (m + n) a-(++) [] ys = ys-(++) (x::xs) ys = x :: xs ++ ys--||| Repeate some value n times-||| @ n the number of times to repeat it-||| @ x the value to repeat-replicate : (n : Nat) -> (x : a) -> Vect n a-replicate Z x = []-replicate (S k) x = x :: replicate k x------------------------------------------------------------------------------------- Zips and unzips-----------------------------------------------------------------------------------||| Combine two equal-length vectors pairwise with some function-zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c-zipWith f [] [] = []-zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys--||| Combine three equal-length vectors into a vector with some function-zipWith3 : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d-zipWith3 f [] [] [] = []-zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs--||| Combine two equal-length vectors pairwise-zip : Vect n a -> Vect n b -> Vect n (a, b)-zip = zipWith (\x,y => (x,y))--||| Combine three equal-length vectors elementwise into a vector of tuples-zip3 : Vect n a -> Vect n b -> Vect n c -> Vect n (a, b, c)-zip3 = zipWith3 (\x,y,z => (x,y,z))--||| Convert a vector of pairs to a pair of vectors-unzip : Vect n (a, b) -> (Vect n a, Vect n b)-unzip [] = ([], [])-unzip ((l, r)::xs) with (unzip xs)- | (lefts, rights) = (l::lefts, r::rights)--||| Convert a vector of three-tuples to a triplet of vectors-unzip3 : Vect n (a, b, c) -> (Vect n a, Vect n b, Vect n c)-unzip3 [] = ([], [], [])-unzip3 ((l,c,r)::xs) with (unzip3 xs)- | (lefts, centers, rights) = (l::lefts, c::centers, r::rights)------------------------------------------------------------------------------------- Equality-----------------------------------------------------------------------------------instance (Eq a) => Eq (Vect n a) where- (==) [] [] = True- (==) (x::xs) (y::ys) =- if x == y then- xs == ys- else- False-------------------------------------------------------------------------------------- Order-----------------------------------------------------------------------------------instance Ord a => Ord (Vect n a) where- compare [] [] = EQ- compare (x::xs) (y::ys) =- if x /= y then- compare x y- else- compare xs ys-------------------------------------------------------------------------------------- Maps-----------------------------------------------------------------------------------instance Functor (Vect n) where- map f [] = []- map f (x::xs) = f x :: map f xs---||| Map a partial function across a vector, returning those elements for which-||| the function had a value.-|||-||| The first projection of the resulting pair (ie the length) will always be-||| at most the length of the input vector. This is not, however, guaranteed-||| by the type.-|||-||| @ f the partial function (expressed by returning `Maybe`)-||| @ xs the vector to check for results-mapMaybe : (f : a -> Maybe b) -> (xs : Vect n a) -> (m : Nat ** Vect m b)-mapMaybe f [] = (_ ** [])-mapMaybe f (x::xs) =- let (len ** ys) = mapMaybe f xs- in case f x of- Just y => (S len ** y :: ys)- Nothing => ( len ** ys)-------------------------------------------------------------------------------------- Folds-----------------------------------------------------------------------------------total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> Vect n t -> acc-foldrImpl f e go [] = go e-foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs--instance Foldable (Vect n) where- foldr f e xs = foldrImpl f e id xs------------------------------------------------------------------------------------- Special folds-----------------------------------------------------------------------------------||| Flatten a vector of equal-length vectors-concat : Vect m (Vect n a) -> Vect (m * n) a-concat [] = []-concat (v::vs) = v ++ concat vs--||| Foldr without seeding the accumulator-foldr1 : (t -> t -> t) -> Vect (S n) t -> t-foldr1 f (x::xs) = foldr f x xs--||| Foldl without seeding the accumulator-foldl1 : (t -> t -> t) -> Vect (S n) t -> t-foldl1 f (x::xs) = foldl f x xs------------------------------------------------------------------------------------ Scans-----------------------------------------------------------------------------------scanl : (b -> a -> b) -> b -> Vect n a -> Vect (S n) b-scanl f q [] = [q]-scanl f q (x::xs) = q :: scanl f (f q x) xs------------------------------------------------------------------------------------- Membership tests-----------------------------------------------------------------------------------||| Search for an item using a user-provided test-||| @ p the equality test-||| @ e the item to search for-||| @ xs the vector to search in-elemBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n a) -> Bool-elemBy p e [] = False-elemBy p e (x::xs) with (p e x)- | True = True- | False = elemBy p e xs--||| Use the default Boolean equality on elements to search for an item-||| @ x what to search for-||| @ xs where to search-elem : Eq a => (x : a) -> (xs : Vect n a) -> Bool-elem = elemBy (==)--||| Find the association of some key with a user-provided comparison-||| @ p the comparison operator for keys (True if they match)-||| @ e the key to look for-lookupBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n (a, b)) -> Maybe b-lookupBy p e [] = Nothing-lookupBy p e ((l, r)::xs) with (p e l)- | True = Just r- | False = lookupBy p e xs--||| Find the assocation of some key using the default Boolean equality test-lookup : Eq a => a -> Vect n (a, b) -> Maybe b-lookup = lookupBy (==)--||| Check if any element of xs is found in elems by a user-provided comparison-||| @ p the comparison operator-||| @ elems the vector to search-||| @ xs what to search for-hasAnyBy : (p : a -> a -> Bool) -> (elems : Vect m a) -> (xs : Vect n a) -> Bool-hasAnyBy p elems [] = False-hasAnyBy p elems (x::xs) with (elemBy p x elems)- | True = True- | False = hasAnyBy p elems xs--||| Check if any element of xs is found in elems using the default Boolean equality test-hasAny : Eq a => Vect m a -> Vect n a -> Bool-hasAny = hasAnyBy (==)------------------------------------------------------------------------------------- Searching with a predicate-----------------------------------------------------------------------------------||| Find the first element of the vector that satisfies some test-||| @ p the test to satisfy-find : (p : a -> Bool) -> (xs : Vect n a) -> Maybe a-find p [] = Nothing-find p (x::xs) with (p x)- | True = Just x- | False = find p xs--||| Find the index of the first element of the vector that satisfies some test-findIndex : (a -> Bool) -> Vect n a -> Maybe Nat-findIndex = findIndex' 0- where- findIndex' : Nat -> (a -> Bool) -> Vect n a -> Maybe Nat- findIndex' cnt p [] = Nothing- findIndex' cnt p (x::xs) with (p x)- | True = Just cnt- | False = findIndex' (S cnt) p xs--||| Find the indices of all elements that satisfy some test-total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)-findIndices = findIndices' 0- where- total findIndices' : Nat -> (a -> Bool) -> Vect m a -> (p ** Vect p Nat)- findIndices' cnt p [] = (_ ** [])- findIndices' cnt p (x::xs) with (findIndices' (S cnt) p xs)- | (_ ** tail) =- if p x then- (_ ** cnt::tail)- else- (_ ** tail)--elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe Nat-elemIndexBy p e = findIndex $ p e--elemIndex : Eq a => a -> Vect m a -> Maybe Nat-elemIndex = elemIndexBy (==)--total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat)-elemIndicesBy p e = findIndices $ p e--total elemIndices : Eq a => a -> Vect m a -> (p ** Vect p Nat)-elemIndices = elemIndicesBy (==)------------------------------------------------------------------------------------- Filters-----------------------------------------------------------------------------------||| Find all elements of a vector that satisfy some test-total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)-filter p [] = ( _ ** [] )-filter p (x::xs) with (filter p xs)- | (_ ** tail) =- if p x then- (_ ** x::tail)- else- (_ ** tail)--||| Make the elements of some vector unique by some test-nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)-nubBy = nubBy' []- where- nubBy' : Vect m a -> (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)- nubBy' acc p [] = (_ ** [])- nubBy' acc p (x::xs) with (elemBy p x acc)- | True = nubBy' acc p xs- | False with (nubBy' (x::acc) p xs)- | (_ ** tail) = (_ ** x::tail)--||| Make the elements of some vector unique by the default Boolean equality-nub : Eq a => Vect n a -> (p ** Vect p a)-nub = nubBy (==)--deleteBy : (a -> a -> Bool) -> a -> Vect n a -> (p ** Vect p a)-deleteBy _ _ [] = (_ ** [])-deleteBy eq x (y::ys) =- let (len ** zs) = deleteBy eq x ys- in if x `eq` y then (_ ** ys) else (S len ** y ::zs)--delete : (Eq a) => a -> Vect n a -> (p ** Vect p a)-delete = deleteBy (==)------------------------------------------------------------------------------------- Splitting and breaking lists-----------------------------------------------------------------------------------||| A tuple where the first element is a Vect of the n first elements and-||| the second element is a Vect of the remaining elements of the original Vect-||| It is equivalent to (take n xs, drop n xs)-||| @ m the index to split at-||| @ xs the Vect to split in two-splitAt : (n : Nat) -> (xs : Vect (n + m) a) -> (Vect n a, Vect m a)-splitAt n xs = (take n xs, drop n xs)--partition : (a -> Bool) -> Vect n a -> ((p ** Vect p a), (q ** Vect q a))-partition p [] = ((_ ** []), (_ ** []))-partition p (x::xs) =- let ((leftLen ** lefts), (rightLen ** rights)) = partition p xs in- if p x then- ((S leftLen ** x::lefts), (rightLen ** rights))- else- ((leftLen ** lefts), (S rightLen ** x::rights))------------------------------------------------------------------------------------- Predicates-----------------------------------------------------------------------------------isPrefixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool-isPrefixOfBy p [] right = True-isPrefixOfBy p left [] = False-isPrefixOfBy p (x::xs) (y::ys) with (p x y)- | True = isPrefixOfBy p xs ys- | False = False--isPrefixOf : Eq a => Vect m a -> Vect n a -> Bool-isPrefixOf = isPrefixOfBy (==)--isSuffixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool-isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right)--isSuffixOf : Eq a => Vect m a -> Vect n a -> Bool-isSuffixOf = isSuffixOfBy (==)------------------------------------------------------------------------------------- Conversions-----------------------------------------------------------------------------------total maybeToVect : Maybe a -> (p ** Vect p a)-maybeToVect Nothing = (_ ** [])-maybeToVect (Just j) = (_ ** [j])--total vectToMaybe : Vect n a -> Maybe a-vectToMaybe [] = Nothing-vectToMaybe (x::xs) = Just x------------------------------------------------------------------------------------- Misc-----------------------------------------------------------------------------------catMaybes : Vect n (Maybe a) -> (p ** Vect p a)-catMaybes [] = (_ ** [])-catMaybes (Nothing::xs) = catMaybes xs-catMaybes ((Just j)::xs) with (catMaybes xs)- | (_ ** tail) = (_ ** j::tail)--diag : Vect n (Vect n a) -> Vect n a-diag [] = []-diag ((x::xs)::xss) = x :: diag (map tail xss)--range : Vect n (Fin n)-range {n=Z} = []-range {n=S _} = FZ :: map FS range--||| Transpose a Vect of Vects, turning rows into columns and vice versa.-|||-||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`.-transpose : Vect m (Vect n a) -> Vect n (Vect m a)-transpose [] = replicate _ []-transpose (x :: xs) = zipWith (::) x (transpose xs)------------------------------------------------------------------------------------- Properties-----------------------------------------------------------------------------------vectConsCong : (x : a) -> (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> (x :: xs = x :: ys)-vectConsCong x xs xs Refl = Refl--vectNilRightNeutral : (xs : Vect n a) -> xs ++ [] = xs-vectNilRightNeutral [] = Refl-vectNilRightNeutral (x :: xs) =- vectConsCong _ _ _ (vectNilRightNeutral xs)--vectAppendAssociative : (x : Vect xLen a) -> (y : Vect yLen a) -> (z : Vect zLen a) -> x ++ (y ++ z) = (x ++ y) ++ z-vectAppendAssociative [] y z = Refl-vectAppendAssociative (x :: xs) ys zs =- vectConsCong _ _ _ (vectAppendAssociative xs ys zs)--
libs/prelude/prelude.ipkg view
@@ -4,11 +4,13 @@ modules = Builtins, Prelude, IO, Prelude.Algebra, Prelude.Basics, Prelude.Bool, Prelude.Cast,- Prelude.Classes, Prelude.Nat, Prelude.Fin, Prelude.List,+ Prelude.Classes, Prelude.Nat, Prelude.List, Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either,- Prelude.Vect, Prelude.Strings, Prelude.Chars, Prelude.Functor,+ Prelude.Strings, Prelude.Chars, Prelude.Functor, Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream, Prelude.Uninhabited, Prelude.Pairs,++ Language.Reflection, Language.Reflection.Errors, Decidable.Equality
main/Main.hs view
@@ -5,10 +5,10 @@ import System.Environment import System.Exit import System.FilePath ((</>), addTrailingPathSeparator)+import System.Directory import Data.Maybe import Data.Version-import Control.Monad.Trans.Error ( ErrorT(..) ) import Control.Monad.Trans.State.Strict ( execStateT, get, put ) import Control.Monad ( when ) @@ -46,6 +46,7 @@ when (ShowIncs `elem` opts) $ runIO showIncs when (ShowLibs `elem` opts) $ runIO showLibs when (ShowLibdir `elem` opts) $ runIO showLibdir+ when (ShowPkgs `elem` opts) $ runIO showPkgs case opt getClient opts of [] -> return () (c:_) -> do setVerbose False@@ -81,7 +82,7 @@ showLibs :: IO b showLibs = do libFlags <- getLibFlags- putStrLn libFlags+ putStrLn $ unwords libFlags exitWith ExitSuccess showLibdir :: IO b@@ -91,5 +92,10 @@ showIncs :: IO b showIncs = do incFlags <- getIncFlags- putStrLn incFlags+ putStrLn $ unwords incFlags+ exitWith ExitSuccess++-- | List idris packages installed+showPkgs :: IO b+showPkgs = do mapM putStrLn =<< installedPackages exitWith ExitSuccess
rts/Makefile view
@@ -8,6 +8,15 @@ CFLAGS += $(GMP_INCLUDE_DIR) $(GMP) -DIDRIS_TARGET_OS="\"$(OS)\"" CFLAGS += -DIDRIS_TARGET_TRIPLE="\"$(MACHINE)\"" +# NOTE: This works around glibc 2.11 not declaring pthread_mutexattr_settype+# and PTHREAD_MUTEX_RECURSIVE by default, causing compilation failures on+# Debian 6 and Ubuntu 10.04 LTS.+ifeq ($(OS), unix)+ifneq ($(shell ldd --version | head -n 1 | grep 2.11),)+ CFLAGS += -D_GNU_SOURCE+endif+endif+ ifeq ($(OS), windows) OBJS += windows/idris_stdfgn.o windows/idris_net.o else
rts/idris_bitstring.c view
@@ -1,8 +1,10 @@+#include <assert.h>+ #include "idris_rts.h" VAL idris_b8CopyForGC(VM *vm, VAL a) { uint8_t A = a->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 1);+ VAL cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS8); cl->info.bits8 = A; return cl;@@ -10,7 +12,7 @@ VAL idris_b16CopyForGC(VM *vm, VAL a) { uint16_t A = a->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 1);+ VAL cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS16); cl->info.bits16 = A; return cl;@@ -18,7 +20,7 @@ VAL idris_b32CopyForGC(VM *vm, VAL a) { uint32_t A = a->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 1);+ VAL cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS32); cl->info.bits32 = A; return cl;@@ -26,7 +28,7 @@ VAL idris_b64CopyForGC(VM *vm, VAL a) { uint64_t A = a->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 1);+ VAL cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS64); cl->info.bits64 = A; return cl;@@ -34,7 +36,7 @@ VAL idris_b8(VM *vm, VAL a) { uint8_t A = GETINT(a);- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) A; return cl;@@ -42,7 +44,7 @@ VAL idris_b16(VM *vm, VAL a) { uint16_t A = GETINT(a);- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) A; return cl;@@ -50,7 +52,7 @@ VAL idris_b32(VM *vm, VAL a) { uint32_t A = GETINT(a);- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) A; return cl;@@ -58,7 +60,7 @@ VAL idris_b64(VM *vm, VAL a) { uint64_t A = GETINT(a);- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) A; return cl;@@ -69,28 +71,28 @@ } VAL idris_b8const(VM *vm, uint8_t a) {- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = a; return cl; } VAL idris_b16const(VM *vm, uint16_t a) {- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = a; return cl; } VAL idris_b32const(VM *vm, uint32_t a) {- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = a; return cl; } VAL idris_b64const(VM *vm, uint64_t a) {- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = a; return cl;@@ -99,7 +101,7 @@ VAL idris_b8Plus(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A + B; return cl;@@ -108,7 +110,7 @@ VAL idris_b8Minus(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A - B; return cl;@@ -117,7 +119,7 @@ VAL idris_b8Times(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A * B; return cl;@@ -126,7 +128,7 @@ VAL idris_b8UDiv(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A / B; return cl;@@ -135,7 +137,7 @@ VAL idris_b8SDiv(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) (((int8_t) A) / ((int8_t) B)); return cl;@@ -144,7 +146,7 @@ VAL idris_b8URem(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A % B; return cl;@@ -153,7 +155,7 @@ VAL idris_b8SRem(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) (((int8_t) A) % ((int8_t) B)); return cl;@@ -181,7 +183,7 @@ VAL idris_b8Compl(VM *vm, VAL a) { uint8_t A = a->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = ~ A; return cl;@@ -190,7 +192,7 @@ VAL idris_b8And(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A & B; return cl;@@ -199,7 +201,7 @@ VAL idris_b8Or(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A | B; return cl;@@ -208,7 +210,7 @@ VAL idris_b8Xor(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A ^ B; return cl;@@ -217,7 +219,7 @@ VAL idris_b8Shl(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A << B; return cl;@@ -226,7 +228,7 @@ VAL idris_b8LShr(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A >> B; return cl;@@ -235,7 +237,7 @@ VAL idris_b8AShr(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) (((int8_t) A) >> ((int8_t) B)); return cl;@@ -244,7 +246,7 @@ VAL idris_b16Plus(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A + B; return cl;@@ -253,7 +255,7 @@ VAL idris_b16Minus(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A - B; return cl;@@ -262,7 +264,7 @@ VAL idris_b16Times(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A * B; return cl;@@ -271,7 +273,7 @@ VAL idris_b16UDiv(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A / B; return cl;@@ -280,7 +282,7 @@ VAL idris_b16SDiv(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) (((int16_t) A) / ((int16_t) B)); return cl;@@ -289,7 +291,7 @@ VAL idris_b16URem(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A % B; return cl;@@ -298,7 +300,7 @@ VAL idris_b16SRem(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) (((int16_t) A) % ((int16_t) B)); return cl;@@ -326,7 +328,7 @@ VAL idris_b16Compl(VM *vm, VAL a) { uint16_t A = a->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = ~ A; return cl;@@ -335,7 +337,7 @@ VAL idris_b16And(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A & B; return cl;@@ -344,7 +346,7 @@ VAL idris_b16Or(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A | B; return cl;@@ -353,7 +355,7 @@ VAL idris_b16Xor(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A ^ B; return cl;@@ -362,7 +364,7 @@ VAL idris_b16Shl(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A << B; return cl;@@ -371,7 +373,7 @@ VAL idris_b16LShr(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A >> B; return cl;@@ -380,7 +382,7 @@ VAL idris_b16AShr(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) (((int16_t) A) >> ((int16_t) B)); return cl;@@ -389,7 +391,7 @@ VAL idris_b32Plus(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A + B; return cl;@@ -398,7 +400,7 @@ VAL idris_b32Minus(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A - B; return cl;@@ -407,7 +409,7 @@ VAL idris_b32Times(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A * B; return cl;@@ -416,7 +418,7 @@ VAL idris_b32UDiv(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A / B; return cl;@@ -425,7 +427,7 @@ VAL idris_b32SDiv(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) (((int32_t) A) / ((int32_t) B)); return cl;@@ -434,7 +436,7 @@ VAL idris_b32URem(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A % B; return cl;@@ -443,7 +445,7 @@ VAL idris_b32SRem(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) (((int32_t) A) % ((int32_t) B)); return cl;@@ -471,7 +473,7 @@ VAL idris_b32Compl(VM *vm, VAL a) { uint32_t A = a->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = ~ A; return cl;@@ -480,7 +482,7 @@ VAL idris_b32And(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A & B; return cl;@@ -489,7 +491,7 @@ VAL idris_b32Or(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A | B; return cl;@@ -498,7 +500,7 @@ VAL idris_b32Xor(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A ^ B; return cl;@@ -507,7 +509,7 @@ VAL idris_b32Shl(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A << B; return cl;@@ -516,7 +518,7 @@ VAL idris_b32LShr(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A >> B; return cl;@@ -525,7 +527,7 @@ VAL idris_b32AShr(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) (((int32_t)A) >> ((int32_t)B)); return cl;@@ -534,7 +536,7 @@ VAL idris_b64Plus(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A + B; return cl;@@ -543,7 +545,7 @@ VAL idris_b64Minus(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A - B; return cl;@@ -552,7 +554,7 @@ VAL idris_b64Times(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A * B; return cl;@@ -561,7 +563,7 @@ VAL idris_b64UDiv(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A / B; return cl;@@ -570,7 +572,7 @@ VAL idris_b64SDiv(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (((int64_t) A) / ((int64_t) B)); return cl;@@ -579,7 +581,7 @@ VAL idris_b64URem(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A % B; return cl;@@ -588,7 +590,7 @@ VAL idris_b64SRem(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (((int64_t) A) % ((int64_t) B)); return cl;@@ -616,7 +618,7 @@ VAL idris_b64Compl(VM *vm, VAL a) { uint64_t A = a->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = ~ A; return cl;@@ -625,7 +627,7 @@ VAL idris_b64And(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A & B; return cl;@@ -634,7 +636,7 @@ VAL idris_b64Or(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A | B; return cl;@@ -643,7 +645,7 @@ VAL idris_b64Xor(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A ^ B; return cl;@@ -652,7 +654,7 @@ VAL idris_b64Shl(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A << B; return cl;@@ -661,7 +663,7 @@ VAL idris_b64LShr(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A >> B; return cl;@@ -670,7 +672,7 @@ VAL idris_b64AShr(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (((int64_t) A) >> ((int64_t) B)); return cl;@@ -678,7 +680,7 @@ VAL idris_b8Z16(VM *vm, VAL a) { uint8_t A = a->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) A; return cl;@@ -686,7 +688,7 @@ VAL idris_b8Z32(VM *vm, VAL a) { uint8_t A = a->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) A; return cl;@@ -694,7 +696,7 @@ VAL idris_b8Z64(VM *vm, VAL a) { uint8_t A = a->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) A; return cl;@@ -702,7 +704,7 @@ VAL idris_b8S16(VM *vm, VAL a) { uint8_t A = a->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) (int16_t) (int8_t) A; return cl;@@ -710,7 +712,7 @@ VAL idris_b8S32(VM *vm, VAL a) { uint8_t A = a->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) (int32_t) (int8_t) A; return cl;@@ -718,7 +720,7 @@ VAL idris_b8S64(VM *vm, VAL a) { uint8_t A = a->info.bits8;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (int64_t) (int8_t) A; return cl;@@ -726,7 +728,7 @@ VAL idris_b16Z32(VM *vm, VAL a) { uint16_t A = a->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) A; return cl;@@ -734,7 +736,7 @@ VAL idris_b16Z64(VM *vm, VAL a) { uint16_t A = a->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) A; return cl;@@ -742,7 +744,7 @@ VAL idris_b16S32(VM *vm, VAL a) { uint16_t A = a->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) (int32_t) (int16_t) A; return cl;@@ -750,7 +752,7 @@ VAL idris_b16S64(VM *vm, VAL a) { uint16_t A = a->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (int64_t) (int16_t) A; return cl;@@ -758,7 +760,7 @@ VAL idris_b16T8(VM *vm, VAL a) { uint16_t A = a->info.bits16;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) A; return cl;@@ -766,7 +768,7 @@ VAL idris_b32Z64(VM *vm, VAL a) { uint32_t A = a->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) A; return cl;@@ -774,7 +776,7 @@ VAL idris_b32S64(VM *vm, VAL a) { uint32_t A = a->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (int64_t) (int32_t) A; return cl;@@ -782,7 +784,7 @@ VAL idris_b32T8(VM *vm, VAL a) { uint32_t A = a->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) A; return cl;@@ -790,7 +792,7 @@ VAL idris_b32T16(VM *vm, VAL a) { uint32_t A = a->info.bits32;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) A; return cl;@@ -798,7 +800,7 @@ VAL idris_b64T8(VM *vm, VAL a) { uint64_t A = a->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) A; return cl;@@ -806,7 +808,7 @@ VAL idris_b64T16(VM *vm, VAL a) { uint64_t A = a->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) A; return cl;@@ -814,9 +816,77 @@ VAL idris_b64T32(VM *vm, VAL a) { uint64_t A = a->info.bits64;- VAL cl = allocate(vm, sizeof(Closure), 0);+ VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) A; return cl; } +// SSE vectors+VAL idris_IDXB8x16(VM* vm, VAL vec, VAL idx) {+ __m128i sse = *vec->info.bits128p;+ uint8_t data[16];+ _mm_storeu_si128((__m128i*)&data, sse);+ return MKB8(vm, data[idx->info.bits32]);+}++VAL idris_IDXB16x8(VM* vm, VAL vec, VAL idx) {+ __m128i sse = *vec->info.bits128p;+ uint16_t data[8];+ _mm_storeu_si128((__m128i*)&data, sse);+ return MKB16(vm, data[idx->info.bits32]);+}++VAL idris_IDXB32x4(VM* vm, VAL vec, VAL idx) {+ __m128i sse = *vec->info.bits128p;+ uint32_t data[4];+ _mm_storeu_si128((__m128i*)&data, sse);+ return MKB32(vm, data[idx->info.bits32]);+}++VAL idris_IDXB64x2(VM* vm, VAL vec, VAL idx) {+ __m128i sse = *vec->info.bits128p;+ uint64_t data[2];+ _mm_storeu_si128((__m128i*)&data, sse);+ return MKB64(vm, data[idx->info.bits32]);+}++VAL idris_b8x16CopyForGC(VM *vm, VAL vec) {+ __m128i sse = *vec->info.bits128p;+ VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);+ SETTY(cl, BITS8X16);+ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);+ *cl->info.bits128p = sse;+ return cl;+}++VAL idris_b16x8CopyForGC(VM *vm, VAL vec) {+ __m128i sse = *vec->info.bits128p;+ VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);+ SETTY(cl, BITS16X8);+ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);+ *cl->info.bits128p = sse;+ return cl;+}++VAL idris_b32x4CopyForGC(VM *vm, VAL vec) {+ __m128i sse = *vec->info.bits128p;+ VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);+ SETTY(cl, BITS32X4);+ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);+ *cl->info.bits128p = sse;+ return cl;+}++VAL idris_b64x2CopyForGC(VM *vm, VAL vec) {+ __m128i sse = *vec->info.bits128p;+ VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);+ SETTY(cl, BITS64X2);+ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);+ *cl->info.bits128p = sse;+ return cl;+}
rts/idris_bitstring.h view
@@ -126,4 +126,14 @@ VAL idris_b64T16(VM *vm, VAL a); VAL idris_b64T32(VM *vm, VAL a); +VAL idris_IDXB8x16(VM* vm, VAL vec, VAL idx);+VAL idris_IDXB16x8(VM* vm, VAL vec, VAL idx);+VAL idris_IDXB32x4(VM* vm, VAL vec, VAL idx);+VAL idris_IDXB64x2(VM* vm, VAL vec, VAL idx);++VAL idris_b8x16CopyForGC(VM *vm, VAL a);+VAL idris_b16x8CopyForGC(VM *vm, VAL a);+VAL idris_b32x4CopyForGC(VM *vm, VAL a);+VAL idris_b64x2CopyForGC(VM *vm, VAL a);+ #endif
rts/idris_gc.c view
@@ -55,6 +55,18 @@ case BITS64: cl = idris_b64CopyForGC(vm, x); break;+ case BITS8X16:+ cl = idris_b8x16CopyForGC(vm, x);+ break;+ case BITS16X8:+ cl = idris_b16x8CopyForGC(vm, x);+ break;+ case BITS32X4:+ cl = idris_b32x4CopyForGC(vm, x);+ break;+ case BITS64X2:+ cl = idris_b64x2CopyForGC(vm, x);+ break; case FWD: return x->info.ptr; default:@@ -69,7 +81,7 @@ int i; int ar; char* scan = vm->heap.heap;- + while(scan < vm->heap.next) { size_t inc = *((size_t*)scan); VAL heap_item = (VAL)(scan+sizeof(size_t));@@ -85,7 +97,7 @@ } break; case STROFFSET:- heap_item->info.str_offset->str + heap_item->info.str_offset->str = copy(vm, heap_item->info.str_offset->str); break; default: // Nothing to copy@@ -101,10 +113,11 @@ 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;- if (vm->heap.old != NULL) - free(vm->heap.old); vm->heap.heap = newheap; #ifdef FORCE_ALIGNMENT@@ -138,21 +151,21 @@ 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) } void idris_gcInfo(VM* vm, int doGC) {- printf("Stack: <BOT %p> <TOP %p>\n", vm->valstack, vm->valstack_top); + printf("Stack: <BOT %p> <TOP %p>\n", vm->valstack, vm->valstack_top); printf("Final heap size %d\n", (int)(vm->heap.size)); printf("Final heap use %d\n", (int)(vm->heap.next - vm->heap.heap)); if (doGC) { idris_gc(vm); } printf("Final heap use after GC %d\n", (int)(vm->heap.next - vm->heap.heap)); #ifdef IDRIS_ENABLE_STATS- printf("Total allocations %d\n", vm->stats.allocations);+ printf("Total allocations %" PRIu64 "\n", vm->stats.allocations); #endif printf("Number of collections %d\n", vm->stats.collections);
rts/idris_gmp.c view
@@ -7,15 +7,26 @@ #include <stdlib.h> #include <string.h> +// TMP HACK! Require this much space in the heap before a GMP operation+// so it doesn't garbage collect in the middle.+// This is highly dodgy and needs to be done better because who knows if+// GMP will need to allocate more than 64k... better to work out how+// much space is needed (or find another way of preventing copying)+#define IDRIS_MAXGMP 65536++void init_gmpalloc() {+ mp_set_memory_functions(idris_alloc, idris_realloc, idris_free);+}+ VAL MKBIGI(int val) { return MKINT((i_int)val); } VAL MKBIGC(VM* vm, char* val) {+ idris_requireAlloc(IDRIS_MAXGMP); mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + - sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init(*bigint);@@ -28,9 +39,10 @@ } VAL MKBIGM(VM* vm, void* big) {+ idris_requireAlloc(IDRIS_MAXGMP);+ mpz_t* bigint;- VAL cl = allocate(vm, sizeof(Closure) + - sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init(*bigint);@@ -43,9 +55,10 @@ } VAL MKBIGMc(VM* vm, void* big) {+ idris_requireAlloc(IDRIS_MAXGMP);+ mpz_t* bigint;- VAL cl = allocate(vm, sizeof(Closure) + - sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init_set(*bigint, *((mpz_t*)big));@@ -57,8 +70,10 @@ } VAL MKBIGUI(VM* vm, unsigned long val) {+ idris_requireAlloc(IDRIS_MAXGMP);+ mpz_t* bigint;- VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init_set_ui(*bigint, val);@@ -70,8 +85,10 @@ } VAL MKBIGSI(VM* vm, signed long val) {+ idris_requireAlloc(IDRIS_MAXGMP);+ mpz_t* bigint;- VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init_set_si(*bigint, val);@@ -83,9 +100,11 @@ } VAL GETBIG(VM * vm, VAL x) {+ idris_requireAlloc(IDRIS_MAXGMP);+ if (ISINT(x)) { mpz_t* bigint;- VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init(*bigint);@@ -106,8 +125,10 @@ } VAL bigAdd(VM* vm, VAL x, VAL y) {+ idris_requireAlloc(IDRIS_MAXGMP);+ mpz_t* bigint;- VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_add(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT);@@ -116,8 +137,10 @@ } VAL bigSub(VM* vm, VAL x, VAL y) {+ idris_requireAlloc(IDRIS_MAXGMP);+ mpz_t* bigint;- VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_sub(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT);@@ -126,8 +149,10 @@ } VAL bigMul(VM* vm, VAL x, VAL y) {+ idris_requireAlloc(IDRIS_MAXGMP);+ mpz_t* bigint;- VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_mul(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT);@@ -136,8 +161,10 @@ } VAL bigDiv(VM* vm, VAL x, VAL y) {+ idris_requireAlloc(IDRIS_MAXGMP);+ mpz_t* bigint;- VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_tdiv_q(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT);@@ -146,8 +173,10 @@ } VAL bigMod(VM* vm, VAL x, VAL y) {+ idris_requireAlloc(IDRIS_MAXGMP);+ mpz_t* bigint;- VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_mod(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT);@@ -229,6 +258,8 @@ } 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); @@ -321,7 +352,7 @@ double val = GETFLOAT(f); mpz_t* bigint;- VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0);+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init_set_d(*bigint, val);
rts/idris_gmp.h view
@@ -7,6 +7,9 @@ #include "mini-gmp.h" #endif +// Set memory allocation functions+void init_gmpalloc();+ VAL MKBIGI(int val); VAL MKBIGC(VM* vm, char* bigint); VAL MKBIGM(VM* vm, void* bigint);
rts/idris_main.c view
@@ -1,6 +1,7 @@ #include "idris_opts.h" #include "idris_stats.h" #include "idris_rts.h"+#include "idris_gmp.h" // The default options should give satisfactory results under many circumstances. RTSOpts opts = { .init_heap_size = 4096000,@@ -15,8 +16,12 @@ __idris_argv = argv; VM* vm = init_vm(opts.max_stack_size, opts.init_heap_size, 1);- initNullaries();+ init_threadkeys();+ init_threaddata(vm);+ init_gmpalloc(); + init_nullaries();+ _idris__123_runMain0_125_(vm, NULL); #ifdef IDRIS_DEBUG@@ -31,6 +36,6 @@ print_stats(&stats); } - freeNullaries();+ free_nullaries(); return EXIT_SUCCESS; }
rts/idris_rts.c view
@@ -11,8 +11,17 @@ #include "idris_gc.h" #include "idris_bitstring.h" +#ifdef HAS_PTHREAD+static pthread_key_t vm_key;+#else+static VM* global_vm;+#endif -VM* init_vm(int stack_size, size_t heap_size, +void free_key(VM *vm) {+ // nothing to free, we just used the VM pointer which is freed elsewhere+}++VM* init_vm(int stack_size, size_t heap_size, int max_threads // not implemented yet ) { @@ -54,11 +63,24 @@ vm->max_threads = max_threads; vm->processes = 0;++#else+ global_vm = vm; #endif STATS_LEAVE_INIT(vm->stats) return vm; } +void init_threadkeys() {+ pthread_key_create(&vm_key, (void*)free_key);+}++void init_threaddata(VM *vm) {+#ifdef HAS_PTHREAD+ pthread_setspecific(vm_key, vm);+#endif+}+ Stats terminate(VM* vm) { Stats stats = vm->stats; STATS_ENTER_EXIT(stats)@@ -78,23 +100,30 @@ return stats; } -void idris_requireAlloc(VM* vm, size_t size) {+void idris_requireAlloc(size_t size) {+#ifdef HAS_PTHREAD+ VM* vm = pthread_getspecific(vm_key);+#else+ VM* vm = global_vm;+#endif+ if (!(vm->heap.next + size < vm->heap.end)) { idris_gc(vm); } #ifdef HAS_PTHREAD int lock = vm->processes > 0; if (lock) { // We only need to lock if we're in concurrent mode- pthread_mutex_lock(&vm->alloc_lock); + pthread_mutex_lock(&vm->alloc_lock); } #endif } -void idris_doneAlloc(VM* vm) {+void idris_doneAlloc() { #ifdef HAS_PTHREAD+ VM* vm = pthread_getspecific(vm_key); int lock = vm->processes > 0; if (lock) { // We only need to lock if we're in concurrent mode- pthread_mutex_unlock(&vm->alloc_lock); + pthread_mutex_unlock(&vm->alloc_lock); } #endif }@@ -103,14 +132,31 @@ return (vm->heap.next + size + sizeof(size_t) < vm->heap.end); } -void* allocate(VM* vm, size_t size, int outerlock) {+void* idris_alloc(size_t size) {+ return allocate(size, 0);+}++void* idris_realloc(void* old, size_t old_size, size_t size) {+ void* ptr = idris_alloc(size);+ memcpy(ptr, old, old_size);+ return ptr;+}++void idris_free(void* ptr, size_t size) {+}++void* allocate(size_t size, int outerlock) { // return malloc(size);+ #ifdef HAS_PTHREAD+ VM* vm = pthread_getspecific(vm_key); int lock = vm->processes > 0 && !outerlock; if (lock) { // not message passing- pthread_mutex_lock(&vm->alloc_lock); + pthread_mutex_lock(&vm->alloc_lock); }+#else+ VM* vm = global_vm; #endif if ((size & 7)!=0) {@@ -130,7 +176,7 @@ memset(ptr, 0, size); #ifdef HAS_PTHREAD if (lock) { // not message passing- pthread_mutex_unlock(&vm->alloc_lock); + pthread_mutex_unlock(&vm->alloc_lock); } #endif return ptr;@@ -138,10 +184,10 @@ idris_gc(vm); #ifdef HAS_PTHREAD if (lock) { // not message passing- pthread_mutex_unlock(&vm->alloc_lock); + pthread_mutex_unlock(&vm->alloc_lock); } #endif- return allocate(vm, size, 0);+ return allocate(size, 0); } }@@ -160,7 +206,7 @@ */ VAL MKFLOAT(VM* vm, double val) {- Closure* cl = allocate(vm, sizeof(Closure), 0);+ Closure* cl = allocate(sizeof(Closure), 0); SETTY(cl, FLOAT); cl -> info.f = val; return cl;@@ -173,8 +219,8 @@ } else { len = strlen(str)+1; }- Closure* cl = allocate(vm, sizeof(Closure) + // Type) + sizeof(char*) +- sizeof(char)*len, 0);+ Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) ++ sizeof(char)*len, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); if (str == NULL) {@@ -192,33 +238,33 @@ } VAL MKPTR(VM* vm, void* ptr) {- Closure* cl = allocate(vm, sizeof(Closure), 0);+ Closure* cl = allocate(sizeof(Closure), 0); SETTY(cl, PTR); cl -> info.ptr = ptr; return cl; } VAL MKMPTR(VM* vm, void* ptr, size_t size) {- Closure* cl = allocate(vm, sizeof(Closure) +- sizeof(ManagedPtr) + size, 0);+ Closure* cl = allocate(sizeof(Closure) ++ sizeof(ManagedPtr) + size, 0); SETTY(cl, MANAGEDPTR); cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure)); cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);- memcpy(cl->info.mptr->data, ptr, size); + memcpy(cl->info.mptr->data, ptr, size); cl->info.mptr->size = size; return cl; } VAL MKFLOATc(VM* vm, double val) {- Closure* cl = allocate(vm, sizeof(Closure), 1);+ Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, FLOAT); cl -> info.f = val; return cl; } VAL MKSTRc(VM* vm, char* str) {- Closure* cl = allocate(vm, sizeof(Closure) + // Type) + sizeof(char*) +- sizeof(char)*strlen(str)+1, 1);+ Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) ++ sizeof(char)*strlen(str)+1, 1); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); @@ -227,51 +273,152 @@ } VAL MKPTRc(VM* vm, void* ptr) {- Closure* cl = allocate(vm, sizeof(Closure), 1);+ Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, PTR); cl -> info.ptr = ptr; return cl; } VAL MKMPTRc(VM* vm, void* ptr, size_t size) {- Closure* cl = allocate(vm, sizeof(Closure) +- sizeof(ManagedPtr) + size, 1);+ Closure* cl = allocate(sizeof(Closure) ++ sizeof(ManagedPtr) + size, 1); SETTY(cl, MANAGEDPTR); cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure)); cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);- memcpy(cl->info.mptr->data, ptr, size); + memcpy(cl->info.mptr->data, ptr, size); cl->info.mptr->size = size; return cl; } VAL MKB8(VM* vm, uint8_t bits8) {- Closure* cl = allocate(vm, sizeof(Closure), 1);+ Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS8); cl -> info.bits8 = bits8; return cl; } VAL MKB16(VM* vm, uint16_t bits16) {- Closure* cl = allocate(vm, sizeof(Closure), 1);+ Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS16); cl -> info.bits16 = bits16; return cl; } VAL MKB32(VM* vm, uint32_t bits32) {- Closure* cl = allocate(vm, sizeof(Closure), 1);+ Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS32); cl -> info.bits32 = bits32; return cl; } VAL MKB64(VM* vm, uint64_t bits64) {- Closure* cl = allocate(vm, sizeof(Closure), 1);+ Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS64); cl -> info.bits64 = bits64; return cl; } +VAL MKB8x16const(VM* vm,+ uint8_t v0, uint8_t v1, uint8_t v2, uint8_t v3,+ uint8_t v4, uint8_t v5, uint8_t v6, uint8_t v7,+ uint8_t v8, uint8_t v9, uint8_t v10, uint8_t v11,+ uint8_t v12, uint8_t v13, uint8_t v14, uint8_t v15) {+ Closure* cl = allocate(sizeof(Closure) + sizeof(__m128i), 1);+ SETTY(cl, BITS8X16);++ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);++ uint8_t data[16];+ data[0]=v0; data[1]=v1; data[2]=v2; data[3]=v3;+ data[4]=v4; data[5]=v5; data[6]=v6; data[7]=v7;+ data[8]=v8; data[9]=v9; data[10]=v10; data[11]=v11;+ data[12]=v12; data[13]=v13; data[14]=v14; data[15]=v15;++ *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);++ return cl;+}++VAL MKB8x16(VM* vm,+ VAL v0, VAL v1, VAL v2, VAL v3,+ VAL v4, VAL v5, VAL v6, VAL v7,+ VAL v8, VAL v9, VAL v10, VAL v11,+ VAL v12, VAL v13, VAL v14, VAL v15) {+ return MKB8x16const(vm,+ v0->info.bits8, v1->info.bits8, v2->info.bits8, v3->info.bits8,+ v4->info.bits8, v5->info.bits8, v6->info.bits8, v7->info.bits8,+ v8->info.bits8, v9->info.bits8, v10->info.bits8, v11->info.bits8,+ v12->info.bits8, v13->info.bits8, v14->info.bits8, v15->info.bits8);+}++VAL MKB16x8const(VM* vm,+ uint16_t v0, uint16_t v1, uint16_t v2, uint16_t v3,+ uint16_t v4, uint16_t v5, uint16_t v6, uint16_t v7) {+ Closure* cl = allocate(sizeof(Closure) + sizeof(__m128i), 1);+ SETTY(cl, BITS16X8);++ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);++ uint16_t data[8];+ data[0]=v0; data[1]=v1; data[2]=v2; data[3]=v3;+ data[4]=v4; data[5]=v5; data[6]=v6; data[7]=v7;++ *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);+ return cl;++}++VAL MKB16x8(VM* vm,+ VAL v0, VAL v1, VAL v2, VAL v3,+ VAL v4, VAL v5, VAL v6, VAL v7) {+ return MKB16x8const(vm,+ v0->info.bits16, v1->info.bits16, v2->info.bits16, v3->info.bits16,+ v4->info.bits16, v5->info.bits16, v6->info.bits16, v7->info.bits16);+}++VAL MKB32x4const(VM* vm,+ uint32_t v0, uint32_t v1, uint32_t v2, uint32_t v3) {+ Closure* cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);+ SETTY(cl, BITS64X2);++ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);++ uint32_t data[4];+ data[0]=v0; data[1]=v1; data[2]=v2; data[3]=v3;++ *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);+ return cl;+}++VAL MKB32x4(VM* vm,+ VAL v0, VAL v1, VAL v2, VAL v3) {+ return MKB32x4const(vm,+ v0->info.bits32, v1->info.bits32, v2->info.bits32, v3->info.bits32);+}++VAL MKB64x2const(VM* vm, uint64_t v0, uint64_t v1) {+ Closure* cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1);+ SETTY(cl, BITS64X2);++ cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16);+ assert ((uintptr_t)cl->info.bits128p % 16 == 0);++ uint64_t data[2];+ data[0]=v0; data[1]=v1;++ *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data);+ return cl;+}++VAL MKB64x2(VM* vm, VAL v0, VAL v1) {+ return MKB64x2const(vm,+ v0->info.bits64,+ v1->info.bits64);+}+ void PROJECT(VM* vm, VAL r, int loc, int arity) { int i; for(i = 0; i < arity; ++i) {@@ -304,7 +451,7 @@ void dumpVal(VAL v) { if (v==NULL) return; int i;- if (ISINT(v)) { + if (ISINT(v)) { printf("%d ", (int)(GETINT(v))); return; }@@ -347,24 +494,62 @@ VAL idris_castIntStr(VM* vm, VAL i) { int x = (int) GETINT(i);- Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*16, 0);+ Closure* cl = allocate(sizeof(Closure) + sizeof(char)*16, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); sprintf(cl -> info.str, "%d", x); return cl; } +VAL idris_castBitsStr(VM* vm, VAL i) {+ Closure* cl;+ ClosureType ty = i->ty;++ switch (ty) {+ case BITS8:+ // max length 8 bit unsigned int str 3 chars (256)+ cl = allocate(sizeof(Closure) + sizeof(char)*4, 0);+ cl->info.str = (char*)cl + sizeof(Closure);+ sprintf(cl->info.str, "%" PRIu8, (uint8_t)i->info.bits8);+ break;+ case BITS16:+ // max length 16 bit unsigned int str 5 chars (65,535)+ cl = allocate(sizeof(Closure) + sizeof(char)*6, 0);+ cl->info.str = (char*)cl + sizeof(Closure);+ sprintf(cl->info.str, "%" PRIu16, (uint16_t)i->info.bits16);+ break;+ case BITS32:+ // max length 32 bit unsigned int str 10 chars (4,294,967,295)+ cl = allocate(sizeof(Closure) + sizeof(char)*11, 0);+ cl->info.str = (char*)cl + sizeof(Closure);+ sprintf(cl->info.str, "%" PRIu32, (uint32_t)i->info.bits32);+ break;+ case BITS64:+ // max length 64 bit unsigned int str 20 chars (18,446,744,073,709,551,615)+ cl = allocate(sizeof(Closure) + sizeof(char)*21, 0);+ cl->info.str = (char*)cl + sizeof(Closure);+ sprintf(cl->info.str, "%" PRIu64, (uint64_t)i->info.bits64);+ break;+ default:+ fprintf(stderr, "Fatal Error: ClosureType %d, not an integer type", ty);+ exit(EXIT_FAILURE);+ }++ SETTY(cl, STRING);+ return cl;+}+ VAL idris_castStrInt(VM* vm, VAL i) { char *end; i_int v = strtol(GETSTR(i), &end, 10);- if (*end == '\0' || *end == '\n' || *end == '\r') + if (*end == '\0' || *end == '\n' || *end == '\r') return MKINT(v);- else - return MKINT(0); + else+ return MKINT(0); } VAL idris_castFloatStr(VM* vm, VAL i) {- Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*32, 0);+ Closure* cl = allocate(sizeof(Closure) + sizeof(char)*32, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); sprintf(cl -> info.str, "%g", GETFLOAT(i));@@ -380,12 +565,11 @@ char *ls = GETSTR(l); // dumpVal(l); // printf("\n");- Closure* cl = allocate(vm, sizeof(Closure) + strlen(ls) + strlen(rs) + 1,- 0);+ Closure* cl = allocate(sizeof(Closure) + strlen(ls) + strlen(rs) + 1, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); strcpy(cl -> info.str, ls);- strcat(cl -> info.str, rs); + strcat(cl -> info.str, rs); return cl; } @@ -451,7 +635,7 @@ } VAL MKSTROFFc(VM* vm, StrOffset* off) {- Closure* cl = allocate(vm, sizeof(Closure) + sizeof(StrOffset), 1);+ Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 1); SETTY(cl, STROFFSET); cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure)); @@ -465,7 +649,7 @@ // If there's no room, just copy the string, or we'll have a problem after // gc moves str if (space(vm, sizeof(Closure) + sizeof(StrOffset))) {- Closure* cl = allocate(vm, sizeof(Closure) + sizeof(StrOffset), 0);+ Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 0); SETTY(cl, STROFFSET); cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure)); @@ -489,8 +673,8 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs) { char *xstr = GETSTR(xs);- Closure* cl = allocate(vm, sizeof(Closure) +- strlen(xstr) + 2, 0);+ Closure* cl = allocate(sizeof(Closure) ++ strlen(xstr) + 2, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); cl -> info.str[0] = (char)(GETINT(x));@@ -504,8 +688,8 @@ VAL idris_strRev(VM* vm, VAL str) { char *xstr = GETSTR(str);- Closure* cl = allocate(vm, sizeof(Closure) +- strlen(xstr) + 1, 0);+ Closure* cl = allocate(sizeof(Closure) ++ strlen(xstr) + 1, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); int y = 0;@@ -532,7 +716,7 @@ } VAL MKBUFFERc(VM* vm, Buffer* buf) {- Closure* cl = allocate(vm, sizeof(Closure) + sizeof *buf + buf->cap, 1);+ Closure* cl = allocate(sizeof(Closure) + sizeof *buf + buf->cap, 1); SETTY(cl, BUFFER); cl->info.buf = (Buffer*)((void*)cl + sizeof(Closure)); memmove(cl->info.buf, buf, sizeof *buf + buf->fill);@@ -549,7 +733,7 @@ size |= size >> (1 << i); ++size; - Closure* cl = allocate(vm, size, 0);+ Closure* cl = allocate(size, 0); SETTY(cl, BUFFER); cl->info.buf = (Buffer*)((void*)cl + sizeof(Closure)); cl->info.buf->cap = size - (sizeof(Closure) + sizeof(Buffer));@@ -557,7 +741,7 @@ } // Following functions cast uint64_t to size_t, which may narrow!-VAL idris_allocate(VM* vm, VAL hint) {+VAL idris_buffer_allocate(VM* vm, VAL hint) { Closure* cl = internal_allocate(vm, hint->info.bits64); cl->info.buf->fill = 0; return cl;@@ -778,6 +962,8 @@ VM* vm = td->vm; VM* callvm = td->callvm; + init_threaddata(vm);+ TOP(0) = td->arg; BASETOP(0); ADDTOP(1);@@ -793,7 +979,7 @@ } void* vmThread(VM* callvm, func f, VAL arg) {- VM* vm = init_vm(callvm->stack_max - callvm->valstack, callvm->heap.size, + VM* vm = init_vm(callvm->stack_max - callvm->valstack, callvm->heap.size, callvm->max_threads); vm->processes=1; // since it can send and receive messages pthread_t t;@@ -809,7 +995,7 @@ td->callvm = callvm; td->fn = f; td->arg = copyTo(vm, arg);- + callvm->processes++; pthread_create(&t, &attr, runThread, td);@@ -817,7 +1003,7 @@ return vm; } -// VM is assumed to be a different vm from the one x lives on +// VM is assumed to be a different vm from the one x lives on VAL copyTo(VM* vm, VAL x) { int i, ar;@@ -882,28 +1068,28 @@ // FIXME: If GC kicks in in the middle of the copy, we're in trouble. // Probably best check there is enough room in advance. (How?) - // Also a problem if we're allocating at the same time as the + // Also a problem if we're allocating at the same time as the // destination thread (which is very likely) // Should the inbox be a different memory space?- + // So: we try to copy, if a collection happens, we do the copy again // under the assumption there's enough space this time. int gcs = dest->stats.collections;- pthread_mutex_lock(&dest->alloc_lock); + pthread_mutex_lock(&dest->alloc_lock); VAL dmsg = copyTo(dest, msg);- pthread_mutex_unlock(&dest->alloc_lock); + pthread_mutex_unlock(&dest->alloc_lock); if (dest->stats.collections > gcs) { // a collection will have invalidated the copy- pthread_mutex_lock(&dest->alloc_lock); + pthread_mutex_lock(&dest->alloc_lock); dmsg = copyTo(dest, msg); // try again now there's room...- pthread_mutex_unlock(&dest->alloc_lock); + pthread_mutex_unlock(&dest->alloc_lock); } 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;@@ -970,7 +1156,7 @@ VAL* nullary_cons; -void initNullaries() {+void init_nullaries() { int i; VAL cl; nullary_cons = malloc(256 * sizeof(VAL));@@ -982,7 +1168,7 @@ } } -void freeNullaries() {+void free_nullaries() { int i; for(i = 0; i < 256; ++i) { free(nullary_cons[i]);
rts/idris_rts.h view
@@ -10,6 +10,8 @@ #endif #include <stdint.h> +#include <emmintrin.h>+ #include "idris_heap.h" #include "idris_stats.h" @@ -21,11 +23,11 @@ #endif // Closures- typedef enum { CON, INT, BIGINT, FLOAT, STRING, STROFFSET, BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD,- MANAGEDPTR, BUFFER+ MANAGEDPTR, BUFFER, BITS8X16, BITS16X8, BITS32X4,+ BITS64X2 } ClosureType; typedef struct Closure *VAL;@@ -72,6 +74,7 @@ uint16_t bits16; uint32_t bits32; uint64_t bits64;+ __m128i* bits128p; Buffer* buf; ManagedPtr* mptr; } info;@@ -82,7 +85,7 @@ VAL* valstack_top; VAL* valstack_base; VAL* stack_max;- + Heap heap; #ifdef HAS_PTHREAD pthread_mutex_t inbox_lock;@@ -106,27 +109,34 @@ } VM; // Create a new VM-VM* init_vm(int stack_size, size_t heap_size, +VM* init_vm(int stack_size, size_t heap_size, int max_threads);+// Initialise thread-local data for this VM+void init_threaddata(VM *vm); // Clean up a VM once it's no longer needed Stats terminate(VM* vm); -// Functions all take a pointer to their VM, and previous stack base, +// Set up key for thread-local data - called once from idris_main+void init_threadkeys();++// Functions all take a pointer to their VM, and previous stack base, // and return nothing. typedef void(*func)(VM*, VAL*); -// Register access +// Register access #define RVAL (vm->ret) #define LOC(x) (*(vm->valstack_base + (x))) #define TOP(x) (*(vm->valstack_top + (x))) #define REG1 (vm->reg1) -// Retrieving values+// align pointer+#define ALIGN(__p, __alignment) ((__p + __alignment - 1) & ~(__alignment - 1)) +// Retrieving values #define GETSTR(x) (ISSTR(x) ? (((VAL)(x))->info.str) : GETSTROFF(x))-#define GETPTR(x) (((VAL)(x))->info.ptr) -#define GETMPTR(x) (((VAL)(x))->info.mptr->data) +#define GETPTR(x) (((VAL)(x))->info.ptr)+#define GETMPTR(x) (((VAL)(x))->info.mptr->data) #define GETFLOAT(x) (((VAL)(x))->info.f) #define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity >> 8 : (-1)) )@@ -184,6 +194,30 @@ VAL MKB32(VM* vm, uint32_t b); VAL MKB64(VM* vm, uint64_t b); +// SSE Vectors+VAL MKB8x16(VM* vm,+ VAL v0, VAL v1, VAL v2, VAL v3,+ VAL v4, VAL v5, VAL v6, VAL v7,+ VAL v8, VAL v9, VAL v10, VAL v11,+ VAL v12, VAL v13, VAL v14, VAL v15);+VAL MKB8x16const(VM* vm,+ uint8_t v0, uint8_t v1, uint8_t v2, uint8_t v3,+ uint8_t v4, uint8_t v5, uint8_t v6, uint8_t v7,+ uint8_t v8, uint8_t v9, uint8_t v10, uint8_t v11,+ uint8_t v12, uint8_t v13, uint8_t v14, uint8_t v15);+VAL MKB16x8(VM* vm,+ VAL v0, VAL v1, VAL v2, VAL v3,+ VAL v4, VAL v5, VAL v6, VAL v7);+VAL MKB16x8const(VM* vm,+ uint16_t v0, uint16_t v1, uint16_t v2, uint16_t v3,+ uint16_t v4, uint16_t v5, uint16_t v6, uint16_t v7);+VAL MKB32x4(VM* vm,+ VAL v0, VAL v1, VAL v2, VAL v3);+VAL MKB32x4const(VM* vm,+ uint32_t v0, uint32_t v1, uint32_t v2, uint32_t v3);+VAL MKB64x2(VM* vm, VAL v0, VAL v1);+VAL MKB64x2const(VM* vm, uint64_t v0, uint64_t v1);+ // following versions don't take a lock when allocating VAL MKFLOATc(VM* vm, double val); VAL MKSTROFFc(VM* vm, StrOffset* off);@@ -198,10 +232,10 @@ #define SETARG(x, i, a) ((x)->info.c.args)[i] = ((VAL)(a)) #define GETARG(x, i) ((x)->info.c.args)[i] -void PROJECT(VM* vm, VAL r, int loc, int arity); +void PROJECT(VM* vm, VAL r, int loc, int arity); void SLIDE(VM* vm, int args); -void* allocate(VM* vm, size_t size, int outerlock);+void* allocate(size_t size, int outerlock); // void* allocCon(VM* vm, int arity, int outerlock); // When allocating from C, call 'idris_requireAlloc' with a size to@@ -210,11 +244,18 @@ // idris_doneAlloc *must* be called when allocation from C is done (as it // may take a lock if other threads are running). -void idris_requireAlloc(VM* vm, size_t size);-void idris_doneAlloc(VM* vm);+void idris_requireAlloc(size_t size);+void idris_doneAlloc(); +// public interface to allocation (note that this may move other pointers+// if allocating beyond the limits given by idris_requireAlloc!)+// 'realloc' just calls alloc and copies; 'free' does nothing+void* idris_alloc(size_t size);+void* idris_realloc(void* old, size_t old_size, size_t size);+void idris_free(void* ptr, size_t size);+ #define allocCon(cl, vm, t, a, o) \- cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*a, o); \+ cl = allocate(sizeof(Closure) + sizeof(VAL)*a, o); \ SETTY(cl, CON); \ cl->info.c.tag_arity = ((t) << 8) | (a); @@ -226,8 +267,8 @@ #define NULL_CON(x) nullary_cons[x] extern VAL* nullary_cons;-void initNullaries();-void freeNullaries();+void init_nullaries();+void free_nullaries(); void* vmThread(VM* callvm, func f, VAL arg); @@ -245,11 +286,11 @@ void dumpStack(VM* vm); // Casts- #define idris_castIntFloat(x) MKFLOAT(vm, (double)(GETINT(x))) #define idris_castFloatInt(x) MKINT((i_int)(GETFLOAT(x))) VAL idris_castIntStr(VM* vm, VAL i);+VAL idris_castBitsStr(VM* vm, VAL i); VAL idris_castStrInt(VM* vm, VAL i); VAL idris_castFloatStr(VM* vm, VAL i); VAL idris_castStrFloat(VM* vm, VAL i);@@ -261,7 +302,6 @@ void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size); // String primitives- VAL idris_concat(VM* vm, VAL l, VAL r); VAL idris_strlt(VM* vm, VAL l, VAL r); VAL idris_streq(VM* vm, VAL l, VAL r);@@ -275,7 +315,7 @@ VAL idris_strRev(VM* vm, VAL str); // Buffer primitives-VAL idris_allocate(VM* vm, VAL hint);+VAL idris_buffer_allocate(VM* vm, VAL hint); VAL idris_appendBuffer(VM* vm, VAL fst, VAL fstLen, VAL cnt, VAL sndLen, VAL sndOff, VAL snd); VAL idris_appendB8Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_appendB16Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val);@@ -312,23 +352,11 @@ int idris_numArgs(); const char *idris_getArg(int i); -// Handle stack overflow. +// Handle stack overflow. // Just reports an error and exits. void stackOverflow(); -// Some FFI help (functions and macros below are all which C code should-// use)--// When allocating from C, call 'idris_requireAlloc' with a size to-// guarantee that no garbage collection will happen (and hence nothing-// will move) until at least size bytes have been allocated.-// idris_doneAlloc *must* be called when allocation from C is done (as it-// may take a lock if other threads are running).--void idris_requireAlloc(VM* vm, size_t size);-void idris_doneAlloc(VM* vm);- // I think these names are nicer for an API... #define idris_constructor allocCon@@ -338,4 +366,4 @@ #include "idris_gmp.h" -#endif +#endif
rts/idris_stats.c view
@@ -10,16 +10,16 @@ clock_t mut = total - stats->init_time - stats->gc_time - stats->exit_time; double mut_sec = (double)mut / CLOCKS_PER_SEC; - int avg_chunk = 0;+ uint64_t avg_chunk = 0; if (stats->alloc_count > 0) {- avg_chunk = (int)((double)stats->allocations / (double)stats->alloc_count);+ avg_chunk = (uint64_t)((double)stats->allocations / (double)stats->alloc_count); } - int alloc_rate = 0;+ uint64_t alloc_rate = 0; if (mut > 0) {- alloc_rate = (int)((double)(stats->allocations) / mut_sec);+ alloc_rate = (uint64_t)((double)(stats->allocations) / mut_sec); }- + double gc_percent = 0.0; double productivity = 0.0; if (total > 0) {@@ -29,11 +29,11 @@ setlocale(LC_NUMERIC, ""); printf("\n");- printf("%'20d bytes allocated in the heap\n", stats->allocations);- printf("%'20d bytes copied during GC\n", stats->copied);- printf("%'20d maximum heap size\n", stats->max_heap_size);- printf("%'20d chunks allocated in the heap\n", stats->alloc_count);- printf("%'20d average chunk size\n\n", avg_chunk);+ printf("%'20" PRIu64 " bytes allocated in the heap\n", stats->allocations);+ printf("%'20" PRIu64 " bytes copied during GC\n", stats->copied);+ printf("%'20" PRIu32 " maximum heap size\n", stats->max_heap_size);+ printf("%'20" PRIu32 " chunks allocated in the heap\n", stats->alloc_count);+ printf("%'20" PRIu64 " average chunk size\n\n", avg_chunk); printf("GC called %d times\n\n", stats->collections); @@ -45,7 +45,7 @@ printf("%%GC time: %.2f%%\n\n", gc_percent); - printf("Alloc rate %'d bytes per MUT sec\n\n", alloc_rate);+ printf("Alloc rate %'" PRIu64 " bytes per MUT sec\n\n", alloc_rate); printf("Productivity %.2f%%\n", productivity); }
rts/idris_stats.h view
@@ -3,16 +3,18 @@ #ifdef IDRIS_ENABLE_STATS #include <time.h>+#include <inttypes.h>+#include <stdint.h> #endif // TODO: measure user time, exclusive/inclusive stats typedef struct { #ifdef IDRIS_ENABLE_STATS- int allocations; // Size of allocated space in bytes for all execution time.- int alloc_count; // How many times alloc is called.- int copied; // Size of space copied during GC.- int max_heap_size; // Maximum heap size achieved.+ uint64_t allocations; // Size of allocated space in bytes for all execution time.+ uint32_t alloc_count; // How many times alloc is called.+ uint64_t copied; // Size of space copied during GC.+ uint32_t max_heap_size; // Maximum heap size achieved. clock_t init_time; // Time spent for vm initialization. clock_t exit_time; // Time spent for vm termination.@@ -20,7 +22,7 @@ clock_t max_gc_pause; // Time spent for longest gc. clock_t start_time; // Time of rts entry point. #endif // IDRIS_ENABLE_STATS- int collections; // How many times gc called.+ uint32_t collections; // How many times gc called. } Stats; // without start time it's a monoid, can we remove start_time it somehow? void print_stats(const Stats * stats);@@ -35,7 +37,7 @@ #define STATS_INIT_STATS(stats) \ memset(&stats, 0, sizeof(Stats)); \- stats.start_time = clock(); + stats.start_time = clock(); #define STATS_ALLOC(stats, size) \ stats.allocations += size; \@@ -60,8 +62,8 @@ #else #define STATS_INIT_STATS(stats) memset(&stats, 0, sizeof(Stats));-#define STATS_ENTER_INIT(stats) -#define STATS_LEAVE_INIT(stats) +#define STATS_ENTER_INIT(stats)+#define STATS_LEAVE_INIT(stats) #define STATS_ENTER_EXIT(stats) #define STATS_LEAVE_EXIT(stats) #define STATS_ALLOC(stats, size)
src/IRTS/CodegenC.hs view
@@ -12,6 +12,7 @@ import Numeric import Data.Char import Data.List (intercalate)+import qualified Data.Vector.Unboxed as V import System.Process import System.Exit import System.IO@@ -24,24 +25,22 @@ (outputFile ci) (outputType ci) (includes ci)- (concatMap mkObj (compileObjs ci))- (concatMap mkLib (compileLibs ci) ++- concatMap incdir (importDirs ci))- (concatMap mkFlag (compilerFlags ci))+ (compileObjs ci)+ (map mkLib (compileLibs ci) +++ map incdir (importDirs ci))+ (compilerFlags ci) (debugLevel ci) - where mkObj f = f ++ " "- mkLib l = "-l" ++ l ++ " "- mkFlag l = l ++ " "- incdir i = "-I" ++ i ++ " "+ where mkLib l = "-l" ++ l+ incdir i = "-I" ++ i codegenC' :: [(Name, SDecl)] -> String -> -- output file name OutputType -> -- generate executable if True, only .o if False [FilePath] -> -- include files- String -> -- extra object files- String -> -- extra compiler flags (libraries)- String -> -- extra compiler flags (anything)+ [String] -> -- extra object files+ [String] -> -- extra compiler flags (libraries)+ [String] -> -- extra compiler flags (anything) DbgLevel -> IO () codegenC' defs out exec incs objs libs flags dbg@@ -64,35 +63,34 @@ comp <- getCC libFlags <- getLibFlags incFlags <- getIncFlags- let gcc = comp ++ " " ++- gccDbg dbg ++ " " ++- gccFlags ++- -- # Any flags defined here which alter the RTS API must also be added to config.mk- " -DHAS_PTHREAD -DIDRIS_ENABLE_STATS" ++- " -I. " ++ objs ++ " -x c " ++- (if (exec == Executable) then "" else " -c ") ++- " " ++ tmpn ++- " " ++ libFlags ++- " " ++ incFlags ++- " " ++ libs ++- " " ++ flags ++- " -o " ++ out+ let args = [gccDbg dbg] +++ gccFlags +++ -- # Any flags defined here which alter the RTS API must also be added to config.mk+ ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS",+ "-I."] ++ objs ++ ["-x", "c"] +++ (if (exec == Executable) then [] else ["-c"]) +++ [tmpn] +++ concatMap words libFlags +++ concatMap words incFlags +++ concatMap words libs +++ concatMap words flags +++ ["-o", out] -- putStrLn gcc- exit <- system gcc+ exit <- rawSystem comp args when (exit /= ExitSuccess) $- putStrLn ("FAILURE: " ++ gcc)+ putStrLn ("FAILURE: " ++ show comp ++ " " ++ show args) headers xs = concatMap (\h -> "#include <" ++ h ++ ">\n")- (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h", "assert.h"])+ (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h"]) debug TRACE = "#define IDRIS_TRACE\n\n" debug _ = "" -- 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 = ["-fwrapv", "-fno-strict-overflow"] gccDbg DEBUG = "-g" gccDbg TRACE = "-O2"@@ -152,7 +150,16 @@ mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)" mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)" mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"- mkConst _ = "MKINT(42424242)"+ mkConst (B8V x) = let x' = V.toList x in "MKB8x16const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")"+ mkConst (B16V x) = let x' = V.toList x in "MKB16x8const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")"+ mkConst (B32V x) = let x' = V.toList x in "MKB32x4const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "UL") x') ++ ")"+ mkConst (B64V x) = let x' = V.toList x in "MKB64x2const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "ULL") x') ++ ")"+ -- if it's a type constant, we won't use it, but equally it shouldn't+ -- report an error. These might creep into generated for various reasons+ -- (especially if erasure is disabled).+ mkConst c | isTypeConst c = "MKINT(42424242)" + mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"+ bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n" bcc i (MKCON l loc tag []) | tag < 256 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"@@ -167,7 +174,7 @@ setArgs i [] = "" setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++ "); " ++ setArgs (i + 1) xs- alloc Nothing tag + alloc Nothing tag = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++ show (length args) ++ ", 0);\n" alloc (Just old) tag@@ -273,7 +280,7 @@ (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n" where fcall (t, arg) = irts_c 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 ++ "); assert(0); exit(-1);"+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" @@ -392,6 +399,7 @@ doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")" doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")" doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"+doOp v (LIntStr (ITFixed _)) [x] = v ++ "idris_castBitsStr(vm, " ++ creg x ++ ")" doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")" doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")" @@ -483,7 +491,7 @@ doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")" doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")" -doOp v LAllocate [x] = v ++ "idris_allocate(vm, " ++ creg x ++ ")"+doOp v LAllocate [x] = v ++ "idris_buffer_allocate(vm, " ++ creg x ++ ")" doOp v LAppendBuffer [a, b, c, d, e, f] = v ++ "idris_appendBuffer(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ "," ++ creg e ++ "," ++ creg f ++ ")" doOp v (LAppend ity en) [a, b, c, d] = v ++ "idris_append" ++ intTyName ity ++ show en ++ "(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ ")" doOp v (LPeek ity en) [x, y] = v ++ "idris_peek" ++ intTyName ity ++ show en ++ "(vm, " ++ creg x ++ "," ++ creg y ++ ")"@@ -496,16 +504,26 @@ doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)" doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"-doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ - "), GETINT(" ++ creg i ++ "))" +doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p +++ "), GETINT(" ++ creg i ++ "))" doOp v (LChInt ITNative) args = v ++ creg (last args) doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args doOp v (LIntCh ITNative) args = v ++ creg (last args) doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args +doOp v c@(LMkVec IT8 _) args = v ++ "MKB8x16(vm, " ++ (intercalate ", " (map creg args)) ++ ")"+doOp v c@(LMkVec IT16 _) args = v ++ "MKB16x8(vm, " ++ (intercalate ", " (map creg args)) ++ ")"+doOp v c@(LMkVec IT32 _) args = v ++ "MKB32x4(vm, " ++ (intercalate ", " (map creg args)) ++ ")"+doOp v c@(LMkVec IT64 _) args = v ++ "MKB64x2(vm, " ++ (intercalate ", " (map creg args)) ++ ")"++doOp v c@(LIdxVec IT8 _) [p, i] = v ++ "idris_IDXB8x16(vm, " ++ creg p ++ ", " ++ creg i ++ ")"+doOp v c@(LIdxVec IT16 _) [p, i] = v ++ "idris_IDXB16x8(vm, " ++ creg p ++ ", " ++ creg i ++ ")"+doOp v c@(LIdxVec IT32 _) [p, i] = v ++ "idris_IDXB32x4(vm, " ++ creg p ++ ", " ++ creg i ++ ")"+doOp v c@(LIdxVec IT64 _) [p, i] = v ++ "idris_IDXB64x2(vm, " ++ creg p ++ ", " ++ creg i ++ ")"+ doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")" doOp v LNoOp args = v ++ creg (last args)-doOp _ op _ = "FAIL /* " ++ show op ++ " */"+doOp _ op args = error "doOp of (" ++ show op ++ ") not implemented, arguments (" ++ show args ++ ")" flUnOp :: String -> String -> String flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"
src/IRTS/CodegenJavaScript.hs view
@@ -57,6 +57,10 @@ || (or $ map (needsBigInt . snd) c) || (or $ map (testConstForBigInt . fst) c) + testBCForBigInt (CASE _ _ c d) =+ maybe False needsBigInt d+ || (or $ map (needsBigInt . snd) c)+ testBCForBigInt _ = False testConstForBigInt :: Const -> Bool@@ -495,13 +499,16 @@ | '\\' <- ch = "\\\\" | '\"' <- ch = "\\\"" | '\'' <- ch = "\\\'"- | ch `elem` asciiTab = "\\u00" ++ fill (showHex (ord ch) "")+ | ch `elem` asciiTab = "\\u" ++ fill (showHex (ord ch) "")+ | ord ch > 255 = "\\u" ++ fill (showHex (ord ch) "") | otherwise = [ch] where fill :: String -> String- fill s = if length s == 1- then '0' : s- else s+ fill s = case length s of+ 1 -> "000" ++ s+ 2 -> "00" ++ s+ 3 -> "0" ++ s+ _ -> s asciiTab = ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
src/IRTS/Compiler.hs view
@@ -62,7 +62,7 @@ -- iputStrLn $ showSep "\n" (map show defs) -- Inlined top level LDecl made here let defsInlined = inlineAll defs- let defsUniq = map (allocUnique (addAlist defsInlined emptyContext)) + let defsUniq = map (allocUnique (addAlist defsInlined emptyContext)) defsInlined let (nexttag, tagged) = addTags 65536 (liftAll defsUniq)@@ -91,13 +91,13 @@ iLOG "Building output" case checked of- OK c -> do return $ CodegenInfo f outty triple cpu + OK c -> do return $ CodegenInfo f outty triple cpu hdrs impdirs objs libs flags NONE c (toAlist defuns) tagged -- runIO $ case codegen of -- ViaC -> codegenC cginfo--- ViaJava -> codegenJava cginfo +-- ViaJava -> codegenJava cginfo -- ViaJavaScript -> codegenJavaScript cginfo -- ViaNode -> codegenNode cginfo -- ViaLLVM -> codegenLLVM cginfo@@ -116,16 +116,16 @@ if ex then return f else return h generate :: Codegen -> FilePath -> CodegenInfo -> IO ()-generate codegen mainmod ir +generate codegen mainmod ir = case codegen of -- Built-in code generators (FIXME: lift these out!)- Via "c" -> codegenC ir + Via "c" -> codegenC ir -- Any external code generator- Via cg -> do let cmd = "idris-" ++ cg ++ " " ++ mainmod ++- " -o " ++ outputFile ir- exit <- system cmd+ Via cg -> do let cmd = "idris-" ++ cg+ args = [mainmod, "-o", outputFile ir]+ exit <- rawSystem cmd args when (exit /= ExitSuccess) $- putStrLn ("FAILURE: " ++ show cmd)+ putStrLn ("FAILURE: " ++ show cmd ++ " " ++ show args) Bytecode -> dumpBC (simpleDecls ir) (outputFile ir) irMain :: TT Name -> Idris LDecl@@ -195,7 +195,7 @@ where (args, sc) = cases_runtime cd - -- Always attempt to inline functions arising from 'case' expressions + -- Always attempt to inline functions arising from 'case' expressions caseName (SN (CaseN _)) = True caseName (SN (WithN _ _)) = True caseName (NS n _) = caseName n@@ -284,7 +284,7 @@ x' <- irTerm vs env x t' <- irTerm vs env t e' <- irTerm vs env e- return (LCase Shared x' + return (LCase Shared x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e' ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t' ])@@ -425,7 +425,7 @@ irTerm vs env (Proj t (-1)) = do t' <- irTerm vs env t- return $ LOp (LMinus (ATInt ITBig)) + return $ LOp (LMinus (ATInt ITBig)) [t', LConst (BI 1)] irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i@@ -458,13 +458,13 @@ | fi == txt "FIntT" = mkIntIty (str intTy) - mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _))) + mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _))) | ff == txt "FFunction" , fa == txt "FAny"- , io == txt "IO" + , io == txt "IO" = FFunctionIO - mkIty' (App (App (P _ (UN ff) _) _) _) + mkIty' (App (App (P _ (UN ff) _) _) _) | ff == txt "FFunction" = FFunction @@ -472,7 +472,8 @@ -- would be better if these FInt types were evaluated at compile time -- TODO: add %eval directive for such things-+ -- Issue #1742 on the issue tracker.+ -- https://github.com/idris-lang/Idris-dev/issues/1742 mkIty "FFloat" = FArith ATFloat mkIty "FInt" = mkIntIty "ITNative" mkIty "FChar" = mkIntIty "ITChar"@@ -521,7 +522,7 @@ | delay == txt "Delay" = do sc' <- irSC vs $ mkForce n' n sc return $ LLet n' (LForce (LV (Glob n))) sc'- + -- There are two transformations in this case: -- -- 1. Newtype-case elimination:
src/IRTS/System.hs view
@@ -38,31 +38,31 @@ getTargetDir = environment "TARGET" >>= maybe getDataDir return #if defined(FREEBSD) || defined(DRAGONFLY)-extraLib = " -L/usr/local/lib"+extraLib = ["-L/usr/local/lib"] #else-extraLib = ""+extraLib = [] #endif #ifdef IDRIS_GMP-gmpLib = " -lgmp"+gmpLib = ["-lgmp"] #else-gmpLib = ""+gmpLib = [] #endif getLibFlags = do dir <- getDataDir- return $ "-L" ++ (dir </> "rts") ++- " -lidris_rts" ++ extraLib ++ gmpLib ++ " -lpthread"+ return $ ["-L" ++ (dir </> "rts"),+ "-lidris_rts"] ++ extraLib ++ gmpLib ++ ["-lpthread"] getIdrisLibDir = do dir <- getDataDir return $ addTrailingPathSeparator dir #if defined(FREEBSD) || defined(DRAGONFLY)-extraInclude = " -I/usr/local/include"+extraInclude = ["-I/usr/local/include"] #else-extraInclude = ""+extraInclude = [] #endif getIncFlags = do dir <- getDataDir- return $ "-I" ++ dir </> "rts" ++ extraInclude+ return $ ("-I" ++ dir </> "rts") : extraInclude getExecutablePom = do dir <- getDataDir return $ dir </> "java" </> "executable_pom.xml"
src/Idris/AbsSyntax.hs view
@@ -19,7 +19,7 @@ import Control.Applicative import Control.Monad.State-import Control.Monad.Error(throwError)+import Control.Monad.Except (throwError, catchError) import Data.List hiding (insert,union) import Data.Char@@ -32,7 +32,6 @@ import Debug.Trace -import Control.Monad.Error (throwError, catchError) import System.IO.Error(isUserError, ioeGetErrorString, tryIOError) import Util.Pretty@@ -97,9 +96,10 @@ addHdr :: Codegen -> String -> Idris () addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i } -addImported :: FilePath -> Idris ()-addImported f = do i <- getIState- putIState $ i { idris_imported = nub $ f : idris_imported i }+addImported :: Bool -> FilePath -> Idris ()+addImported pub f + = do i <- getIState+ putIState $ i { idris_imported = nub $ (f, pub) : idris_imported i } addLangExt :: LanguageExt -> Idris () addLangExt TypeProviders = do i <- getIState@@ -114,12 +114,12 @@ -- Transforms are organised by the function being applied on the lhs of the -- transform, to make looking up appropriate transforms quicker addTrans :: Name -> (Term, Term) -> Idris ()-addTrans basefn t +addTrans basefn t = do i <- getIState let t' = case lookupCtxtExact basefn (idris_transforms i) of Just def -> (t : def) Nothing -> [t]- putIState $ i { idris_transforms = addDef basefn t' + putIState $ i { idris_transforms = addDef basefn t' (idris_transforms i) } addErrRev :: (Term, Term) -> Idris ()@@ -130,8 +130,8 @@ totcheck n = do i <- getIState; putIState $ i { idris_totcheck = idris_totcheck i ++ [n] } defer_totcheck :: (FC, Name) -> Idris ()-defer_totcheck n - = do i <- getIState; +defer_totcheck n+ = do i <- getIState; putIState $ i { idris_defertotcheck = nub (idris_defertotcheck i ++ [n]) } clear_totcheck :: Idris ()@@ -183,7 +183,7 @@ putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) } addTyInferred :: Name -> Idris ()-addTyInferred n +addTyInferred n = do i <- getIState putIState $ i { idris_tyinfodata = addDef n TIPartial (idris_tyinfodata i) }@@ -197,7 +197,7 @@ findMVApps x y = do let (fx, argsx) = unApply x let (fy, argsy) = unApply y- if (not (fx == fy)) + if (not (fx == fy)) then do tryAddMV fx y tryAddMV fy x@@ -211,17 +211,17 @@ tryAddMV _ _ = return () addConstraintRule :: Name -> Term -> Idris ()- addConstraintRule n t + addConstraintRule n t = do ist <- get logLvl 1 $ "TI constraint: " ++ show (n, t) case lookupCtxt n (idris_tyinfodata ist) of- [TISolution ts] -> + [TISolution ts] -> do mapM_ (checkConsistent t) ts- let ti' = addDef n (TISolution (t : ts)) + let ti' = addDef n (TISolution (t : ts)) (idris_tyinfodata ist) put $ ist { idris_tyinfodata = ti' }- _ -> - do let ti' = addDef n (TISolution [t]) + _ ->+ do let ti' = addDef n (TISolution [t]) (idris_tyinfodata ist) put $ ist { idris_tyinfodata = ti' } @@ -233,14 +233,14 @@ do let (fx, _) = unApply x let (fy, _) = unApply y case (fx, fy) of- (P (TCon _ _) n _, P (TCon _ _) n' _) -> errWhen (n/=n) + (P (TCon _ _) n _, P (TCon _ _) n' _) -> errWhen (n/=n) (P (TCon _ _) n _, Constant _) -> errWhen True (Constant _, P (TCon _ _) n' _) -> errWhen True- (P (DCon _ _ _) n _, P (DCon _ _ _) n' _) -> errWhen (n/=n) + (P (DCon _ _ _) n _, P (DCon _ _ _) n' _) -> errWhen (n/=n) _ -> return () - where errWhen True - = throwError (At fc + where errWhen True+ = throwError (At fc (CantUnify False x y (Msg "") [] 0)) errWhen False = return () @@ -310,9 +310,21 @@ [ns] -> ns _ -> [] +-- Issue #1737 in the Issue Tracker.+-- https://github.com/idris-lang/Idris-dev/issues/1737 addToCalledG :: Name -> [Name] -> Idris () addToCalledG n ns = return () -- TODO +push_estack :: Name -> Idris ()+push_estack n = do i <- getIState+ putIState (i { elab_stack = n : elab_stack i })++pop_estack :: Idris ()+pop_estack = do i <- getIState+ putIState (i { elab_stack = ptail (elab_stack i) })+ where ptail [] = []+ ptail (x : xs) = xs+ -- Add a class instance function. Dodgy hack: Put integer instances first in the -- list so they are resolved by default. -- Dodgy hack 2: put constraint chasers (@@) last@@ -333,7 +345,7 @@ insI i (n : ns) | chaser n = i : n : ns | otherwise = n : insI i ns - chaser (UN nm) + chaser (UN nm) | ('@':'@':_) <- str nm = True chaser (NS n _) = chaser n chaser _ = False@@ -367,6 +379,7 @@ addNameIdx :: Name -> Idris (Int, Name) addNameIdx n = do i <- getIState let (i', x) = addNameIdx' i n+ putIState i' return x addNameIdx' :: IState -> Name -> (IState, (Int, Name))@@ -377,10 +390,18 @@ _ -> let i' = fst (idris_nameIdx i) + 1 in (i { idris_nameIdx = (i', addDef n (i', n) idxs) }, (i', n)) +getSymbol :: Name -> Idris Name+getSymbol n = do i <- getIState+ case M.lookup n (idris_symbols i) of+ Just n' -> return n'+ Nothing -> do let sym' = M.insert n n (idris_symbols i)+ put (i { idris_symbols = sym' })+ return n+ getHdrs :: Codegen -> Idris [String] getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i) -getImported :: Idris [FilePath]+getImported :: Idris [(FilePath, Bool)] getImported = do i <- getIState; return (idris_imported i) setErrSpan :: FC -> Idris ()@@ -421,6 +442,9 @@ runIO :: IO a -> Idris a runIO x = liftIO (tryIOError x) >>= either (throwError . Msg . show) return -- TODO: create specific Idris exceptions for specific IO errors such as "openFile: does not exist"+--+-- Issue #1738 on the issue tracker.+-- https://github.com/idris-lang/Idris-dev/issues/1738 getName :: Idris Int getName = do i <- getIState;@@ -454,9 +478,9 @@ -- the .ibc, which is all we need after all the analysis is done) clearPTypes :: Idris () clearPTypes = do i <- get- let ctxt = tt_ctxt i + let ctxt = tt_ctxt i put (i { tt_ctxt = mapDefCtxt pErase ctxt })- where pErase (CaseOp c t tys orig tot cds) + where pErase (CaseOp c t tys orig tot cds) = CaseOp c t tys orig [] (pErase' cds) pErase x = x pErase' (CaseDefs _ (cs, c) _ rs)@@ -474,8 +498,8 @@ isUndefined :: FC -> Name -> Idris Bool isUndefined fc n = do i <- getContext- case lookupTy n i of- (_:_) -> return False+ case lookupTyExact n i of+ Just _ -> return False _ -> return True setContext :: Context -> Idris ()@@ -488,7 +512,7 @@ addConstraints fc (v, cs) = do i <- getIState let ctxt = tt_ctxt i- let ctxt' = ctxt { uconstraints = cs ++ uconstraints ctxt,+ let ctxt' = ctxt { uconstraints = nub cs ++ uconstraints ctxt, next_tvar = v } let ics = zip cs (repeat fc) ++ idris_constraints i putIState $ i { tt_ctxt = ctxt', idris_constraints = ics }@@ -503,7 +527,7 @@ i <- getIState putIState $ i { idris_metavars = map (\(n, (i, top, _, isTopLevel)) -> (n, (top, i, isTopLevel))) ns ++ idris_metavars i }- where + where -- 'tidyNames' is to generate user accessible names in case they are -- needed in tactic scripts tidyNames used (Bind (MN i x) b sc)@@ -869,21 +893,21 @@ mkShadow (MN i n) = MN (i+1) n mkShadow (NS x s) = NS (mkShadow x) s - en (PLam n t s)+ en (PLam fc n t s) | n `elem` (map fst ps ++ ns) = let n' = mkShadow n in- PLam n' (en t) (en (shadow n n' s))- | otherwise = PLam n (en t) (en s)+ PLam fc n' (en t) (en (shadow n n' s))+ | otherwise = PLam fc n (en t) (en s) en (PPi p n t s) | n `elem` (map fst ps ++ ns) = let n' = mkShadow n in -- TODO THINK SHADOWING TacImp? PPi (enTacImp p) n' (en t) (en (shadow n n' s)) | otherwise = PPi (enTacImp p) n (en t) (en s)- en (PLet n ty v s)+ en (PLet fc n ty v s) | n `elem` (map fst ps ++ ns) = let n' = mkShadow n in- PLet n' (en ty) (en v) (en (shadow n n' s))- | otherwise = PLet n (en ty) (en v) (en s)+ PLet fc n' (en ty) (en v) (en (shadow n n' s))+ | otherwise = PLet fc n (en ty) (en v) (en s) -- FIXME: Should only do this in a type signature! en (PDPair f p (PRef f' n) t r) | n `elem` (map fst ps ++ ns) && t /= Placeholder@@ -1022,14 +1046,14 @@ = 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) = PClass doc info f- (map (expandParams dec ps ns []) cs)+ (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs) n (map (mapsnd (expandParams dec ps ns [])) params) pDocs (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- (map (expandParams dec ps ns []) cs)+ (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs) n (map (expandParams dec ps ns []) params) (expandParams dec ps ns [] ty)@@ -1075,12 +1099,12 @@ addStatics n tm ptm = do let (statics, dynamics) = initStatics tm ptm ist <- getIState- let paramnames + let paramnames = nub $ case lookupCtxtExact n (idris_fninfo ist) of Just p -> getNamesFrom 0 (fn_params p) tm ++ concatMap (getParamNames ist) (map snd statics) _ -> concatMap (getParamNames ist) (map snd statics)- + let stnames = nub $ concatMap freeArgNames (map snd statics) let dnames = (nub $ concatMap freeArgNames (map snd dynamics)) \\ paramnames@@ -1100,13 +1124,13 @@ putIState $ i { idris_statics = addDef n stpos (idris_statics i) } addIBC (IBCStatic n) where- initStatics (Bind n (Pi ty _) sc) (PPi p n' t s)+ initStatics (Bind n (Pi _ ty _) sc) (PPi p n' t s) | n /= n' = let (static, dynamic) = initStatics sc (PPi p n' t s) in (static, (n, ty) : dynamic)- initStatics (Bind n (Pi ty _) sc) (PPi p n' _ s)+ initStatics (Bind n (Pi _ ty _) sc) (PPi p n' _ s) = let (static, dynamic) = initStatics (instantiate (P Bound n ty) sc) s in if pstatic p == Static then ((n, ty) : static, dynamic)- else if (not (searchArg p)) + else if (not (searchArg p)) then (static, (n, ty) : dynamic) else (static, dynamic) initStatics t pt = ([], [])@@ -1116,19 +1140,19 @@ Just ti -> getNamePos 0 (param_pos ti) args Nothing -> [] where getNamePos i ps [] = []- getNamePos i ps (P _ n _ : as) + getNamePos i ps (P _ n _ : as) | i `elem` ps = n : getNamePos (i + 1) ps as getNamePos i ps (_ : as) = getNamePos (i + 1) ps as- getParamNames ist (Bind t (Pi (P _ n _) _) sc)+ getParamNames ist (Bind t (Pi _ (P _ n _) _) sc) = n : getParamNames ist sc getParamNames ist _ = [] - getNamesFrom i ps (Bind n (Pi _ _) sc)+ getNamesFrom i ps (Bind n (Pi _ _ _) sc) | i `elem` ps = n : getNamesFrom (i + 1) ps sc | otherwise = getNamesFrom (i + 1) ps sc getNamesFrom i ps sc = [] - freeArgNames (Bind n (Pi ty _) sc) + freeArgNames (Bind n (Pi _ ty _) sc) = nub $ freeNames ty ++ freeNames sc -- treat '->' as fn here freeArgNames tm = let (_, args) = unApply tm in concatMap freeNames args@@ -1140,7 +1164,7 @@ searchArg (TacImp _ _ _) = True searchArg _ = False - staticList sts (Bind n (Pi _ _) sc) = (n `elem` sts) : staticList sts sc+ staticList sts (Bind n (Pi _ _ _) sc) = (n `elem` sts) : staticList sts sc staticList _ _ = [] -- Dealing with implicit arguments@@ -1199,11 +1223,11 @@ let ns = implicitNamesIn (map iname uimpls) ist t let badnames = filter (\n -> not (implicitable n) && n `notElem` (map iname uimpls)) ns- when (not (null badnames)) $ - throwError (At fc (Elaborating "type of " n + when (not (null badnames)) $+ throwError (At fc (Elaborating "type of " n (NoSuchVariable (head badnames))))- let cs = getArgnames t -- get already bound names - let addimpls = filter (\n -> iname n `notElem` cs) uimpls + let cs = getArgnames t -- get already bound names+ let addimpls = filter (\n -> iname n `notElem` cs) uimpls -- if all names in the arguments of addconsts appear in ns, -- add the constraint implicitly return (bindFree ns (doAdd addimpls ns t))@@ -1218,15 +1242,15 @@ -- if all of args in ns, then add it doAdd (UImplicit n ty : cs) ns t | elem n ns- = PPi (Imp [] Dynamic False) n ty (doAdd cs ns t)+ = PPi (Imp [] Dynamic False Nothing) n ty (doAdd cs ns t) | otherwise = doAdd cs ns t -- bind the free names which weren't in the using block bindFree [] tm = tm- bindFree (n:ns) tm + bindFree (n:ns) tm | elem n (map iname uimpls) = bindFree ns tm- | otherwise - = PPi (Imp [] Dynamic False) n Placeholder (bindFree ns tm)+ | otherwise+ = PPi (Imp [] Dynamic False Nothing) n Placeholder (bindFree ns tm) getArgnames (PPi _ n c sc) = n : getArgnames sc@@ -1241,21 +1265,22 @@ = (n, (p, t)) : collectImps sc collectImps _ = [] - getImps (Bind n (Pi t _) sc) imps+ getImps (Bind n (Pi (Just _) _ _) sc) imps = getImps sc imps+ 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 _ _) t' + argInfo n (Imp opt _ _ _) t' = (True, PImp (getPriority i t') True opt n t') argInfo n (Exp opt _ _) t' = (InaccessibleArg `elem` opt, PExp (getPriority i t') opt n t')- argInfo n (Constraint opt _) t' + argInfo n (Constraint opt _) t' = (InaccessibleArg `elem` opt, PConstraint 10 opt n t')- argInfo n (TacImp opt _ scr) t' + argInfo n (TacImp opt _ scr) t' = (InaccessibleArg `elem` opt, PTacImplicit 10 opt n scr t')- getImps (Bind n (Pi t _) sc) imps = impBind n t : getImps sc imps+ getImps (Bind n (Pi _ t _) sc) imps = impBind n t : getImps sc imps where impBind n t = (True, PImp 1 True [] n Placeholder) getImps sc tm = [] @@ -1265,6 +1290,9 @@ -- This has become a right mess already. Better redo it some time... -- TODO: This is obsoleted by the new way of elaborating types, but there's still -- a couple of places which use it. Clean them up!+--+-- Issue 1739 in the issue tracker+-- https://github.com/idris-lang/Idris-dev/issues/1739 implicit :: ElabInfo -> SyntaxInfo -> Name -> PTerm -> Idris PTerm implicit info syn n ptm = implicit' info syn [] n ptm @@ -1283,11 +1311,11 @@ where -- Detect unknown names in default arguments and throw error if found. defaultArgCheck :: [Name] -> [PArg] -> Idris ()- defaultArgCheck knowns params = foldM_ notFoundInDefault knowns params + defaultArgCheck knowns params = foldM_ notFoundInDefault knowns params notFoundInDefault :: [Name] -> PArg -> Idris [Name] notFoundInDefault kns (PTacImplicit _ _ n script _)- = do i <- getIState + = do i <- getIState case notFound kns (namesIn [] i script) of Nothing -> return (n:kns) Just name -> throwError (NoSuchVariable name)@@ -1331,7 +1359,7 @@ = do (decls, ns) <- get let isn = concatMap (namesIn uvars ist) (map getTm as) put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))- imps top env (PPi (Imp l _ _) n ty sc)+ imps top env (PPi (Imp l _ _ _) n ty sc) = do let isn = nub (implNamesIn uvars ty) `dropAll` [n] (decls , ns) <- get put (PImp (getPriority ist ty) True l n Placeholder : decls,@@ -1388,7 +1416,7 @@ = do (decls, ns) <- get let isn = concatMap (namesIn uvars ist) as put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))- imps top env (PLam n ty sc)+ imps top env (PLam fc n ty sc) = do imps False env ty imps False (n:env) sc imps top env (PHidden tm) = imps False env tm@@ -1399,8 +1427,8 @@ pibind using [] sc = sc pibind using (n:ns) sc = case lookup n using of- Just ty -> PPi (Imp [] Dynamic False) n ty (pibind using ns sc)- Nothing -> PPi (Imp [] Dynamic False) n Placeholder+ Just ty -> PPi (Imp [] Dynamic False Nothing) n ty (pibind using ns sc)+ Nothing -> PPi (Imp [] Dynamic False Nothing) n Placeholder (pibind using ns sc) -- Add implicit arguments in function calls@@ -1429,7 +1457,7 @@ | f `elem` infns = PInferRef fc f | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat qq ist fc f ds [] ai qq env ds (PHidden (PRef fc f))- | not (f `elem` map fst env) = handleErr $ aiFn inpat False qq ist fc f ds []+ | not (f `elem` map fst env) = PHidden (handleErr $ aiFn inpat False qq 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@@ -1480,15 +1508,24 @@ -- definition which is passed through addImpl again with more scope -- information PCase fc c' os- ai qq env ds (PLam n ty sc)- = let ty' = ai qq env ds ty- sc' = ai qq ((n, Just ty):env) ds sc in- PLam n ty' sc'- ai qq env ds (PLet n ty val sc)- = let ty' = ai qq env ds ty- val' = ai qq env ds val- sc' = ai qq ((n, Just ty):env) ds sc in- PLet n ty' val' sc'+ -- If the name in a lambda is a constructor name, do this as a 'case'+ -- instead (it is harmless to do so, especially since the lambda will+ -- be lifted anyway!)+ ai qq env ds (PLam fc n ty sc)+ = case lookupDef n (tt_ctxt ist) of+ [] -> let ty' = ai qq env ds ty+ sc' = ai qq ((n, Just ty):env) ds sc in+ PLam fc n ty' sc'+ _ -> ai qq env ds (PLam fc (sMN 0 "lamp") ty+ (PCase fc (PRef fc (sMN 0 "lamp") )+ [(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+ val' = ai qq env ds val+ sc' = ai qq ((n, Just ty):env) ds sc in+ PLet fc n ty' val' sc'+ _ -> 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@@ -1545,7 +1582,7 @@ let nh = filter (\(n, _) -> notHidden n) ns let ns' = case trimAlts ds nh of [] -> nh- x -> x + x -> x case ns' of [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as) [] -> if f `elem` (map fst (idris_metavars ist))@@ -1557,7 +1594,7 @@ (insertImpl ns as)) alts where trimAlts [] alts = alts- trimAlts ns alts + trimAlts ns alts = filter (\(x, _) -> any (\d -> d `isPrefixOf` nspace x) ns) alts nspace (NS _ s) = s@@ -1568,8 +1605,8 @@ _ -> True getAccessibility n- = case lookupDefAcc n False (tt_ctxt ist) of- [(n,t)] -> t+ = case lookupDefAccExact n False (tt_ctxt ist) of+ Just (n,t) -> t _ -> Public insertImpl :: [PArg] -> [PArg] -> [PArg]@@ -1612,6 +1649,8 @@ insImpAcc (M.insert n sc pnas) ps given imps insImpAcc _ expected [] imps = imps -- so that unused implicits give error -- TODO: report here, and prune alternatives+ -- Issue #1740 in the Issue Tracker+-- https://github.com/idris-lang/Idris-dev/issues/1740 insImpAcc _ _ given imps = given ++ imps find n [] acc = Nothing@@ -1622,8 +1661,6 @@ find n (g : gs) acc = find n gs (g : acc) -- replace non-linear occurrences with _--- ASSUMPTION: This is called before adding 'alternatives' because otherwise--- it is hard to get right! stripLinear :: IState -> PTerm -> PTerm stripLinear i tm = evalState (sl tm) [] where@@ -1633,18 +1670,26 @@ = return $ PRef fc f | otherwise = do ns <- get if (f `elem` ns)- then return Placeholder+ then return $ PHidden (PRef fc f) -- Placeholder else do put (f : ns) return (PRef fc f) sl (PPatvar fc f) = do ns <- get if (f `elem` ns)- then return Placeholder+ then return $ PHidden (PPatvar fc f) -- Placeholder else do put (f : ns) return (PPatvar fc f)- sl t@(PAlternative _ (a : as)) = do sl a- return t- sl (PApp fc fn args) = do -- Just the args, fn isn't matchable as a var + -- Assumption is that variables are all the same in each alternative+ sl t@(PAlternative b as) = do ns <- get+ as' <- slAlts ns as+ return (PAlternative b as')+ where slAlts ns (a : as) = do put ns+ a' <- sl a+ as' <- slAlts ns as+ 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 (PApp fc fn args) = do -- Just the args, fn isn't matchable as a var args' <- mapM slA args return $ PApp fc fn args' where slA (PImp p m l n t) = do t' <- sl t@@ -1667,17 +1712,26 @@ stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where su :: PTerm -> PTerm su (PRef fc f)- | (Bind n (Pi t _) sc :_) <- lookupTy f (tt_ctxt i) + | (Bind n (Pi _ t _) sc :_) <- lookupTy f (tt_ctxt i) = Placeholder- su (PApp fc fn args) - = PApp fc fn (fmap (fmap su) args)- su (PAlternative b alts) + su (PApp fc f@(PRef _ fn) args)+ | isDConName fn ctxt + = PApp fc f (fmap (fmap su) args)+ su (PApp fc f args)+ = PHidden (PApp fc f args)+ su (PAlternative b alts) = let alts' = filter (/= Placeholder) (map su alts) in if null alts' then Placeholder else PAlternative b alts' su (PPair fc p l r) = PPair fc p (su l) (su r) su (PDPair fc p l t r) = PDPair fc p (su l) (su t) (su r)+ su t@(PLam fc _ _ _) = PHidden t+ su t@(PPi _ _ _ _) = PHidden t+ su t@(PEq _ _ _ _ _) = PHidden t su t = t++ ctxt = tt_ctxt i+ stripUnmatchable i tm = tm mkPApp fc a f [] = f@@ -1766,7 +1820,7 @@ match (PApp _ x []) (PRef f n) = match x (PRef f n) match (PRef _ n) tm@(PRef _ n') | n == n' && not names &&- (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i)) + (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i)) || tm == Placeholder) = return [(n, tm)] -- if one namespace is missing, drop the other@@ -1777,7 +1831,7 @@ | not names && (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i)) || tm == Placeholder) = return [(n, tm)]- match (PEq _ _ _ l r) (PEq _ _ _ l' r') + match (PEq _ _ _ l r) (PEq _ _ _ l' r') = do ml <- match' l l' mr <- match' r r' return (ml ++ mr)@@ -1818,14 +1872,22 @@ match (PPi _ _ t s) (PPi _ _ t' s') = do mt <- match' t t' ms <- match' s s' return (mt ++ ms)- match (PLam _ t s) (PLam _ t' s') = do mt <- match' t t'- ms <- match' s s'- return (mt ++ ms)- match (PLet _ t ty s) (PLet _ t' ty' s') = do mt <- match' t t'- mty <- match' ty ty'- ms <- match' s s'- return (mt ++ mty ++ ms)- match (PHidden x) (PHidden y) = match' x y+ match (PLam _ _ t s) (PLam _ _ t' s') = do mt <- match' t t'+ ms <- match' s s'+ return (mt ++ ms)+ match (PLet _ _ t ty s) (PLet _ _ t' ty' s') = do mt <- match' t t'+ mty <- match' ty ty'+ ms <- match' s s'+ return (mt ++ mty ++ ms)+ match (PHidden x) (PHidden y)+ | RightOK xs <- match x y = return xs -- to collect variables+ | otherwise = return [] -- Otherwise hidden things are unmatchable+ match (PHidden x) y + | RightOK xs <- match x y = return xs + | otherwise = return []+ 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 match (PNoImplicits x) y = match' x y@@ -1859,7 +1921,7 @@ substMatchShadow :: Name -> [Name] -> PTerm -> PTerm -> PTerm substMatchShadow n shs tm t = sm shs t where sm xs (PRef _ n') | n == n' = tm- sm xs (PLam x t sc) = PLam x (sm xs t) (sm xs sc)+ sm xs (PLam fc x t sc) = PLam fc x (sm xs t) (sm xs sc) sm xs (PPi p x t sc) | x `elem` xs = let x' = nextName x in@@ -1886,9 +1948,9 @@ shadow :: Name -> Name -> PTerm -> PTerm shadow n n' t = sm t where sm (PRef fc x) | n == x = PRef fc n'- sm (PLam x t sc) | n /= x = PLam x (sm t) (sm sc)+ 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)- sm (PLet x t v sc) | n /= x = PLet x (sm t) (sm v) (sm sc)+ sm (PLet fc x t v sc) | n /= x = PLet fc x (sm t) (sm v) (sm sc) sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as) sm (PAppBind f x as) = PAppBind f (sm x) (map (fmap sm) as) sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as)@@ -1927,7 +1989,7 @@ mkUniqT tac = return tac mkUniq :: PTerm -> State (S.Set Name) PTerm- mkUniq (PLam n ty sc)+ mkUniq (PLam fc n ty sc) = do env <- get (n', sc') <- if n `S.member` env@@ -1938,7 +2000,7 @@ put (S.insert n' env) ty' <- mkUniq ty sc'' <- mkUniq sc'- return $! PLam n' ty' sc''+ return $! PLam fc n' ty' sc'' mkUniq (PPi p n ty sc) = do env <- get (n', sc') <-@@ -1951,7 +2013,7 @@ ty' <- mkUniq ty sc'' <- mkUniq sc' return $! PPi p n' ty' sc''- mkUniq (PLet n ty val sc)+ mkUniq (PLet fc n ty val sc) = do env <- get (n', sc') <- if n `S.member` env@@ -1962,7 +2024,7 @@ put (S.insert n' env) ty' <- mkUniq ty; val' <- mkUniq val sc'' <- mkUniq sc'- return $! PLet n' ty' val' sc''+ return $! PLet fc n' ty' val' sc'' mkUniq (PApp fc t args) = do t' <- mkUniq t args' <- mapM mkUniqA args@@ -2002,5 +2064,3 @@ mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts) mkUniq (PTactics ts) = liftM PTactics (mapM mkUniqT ts) mkUniq t = return t--
src/Idris/AbsSyntaxTree.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor,- TypeSynonymInstances, PatternGuards #-}+ DeriveDataTypeable, TypeSynonymInstances, PatternGuards #-} module Idris.AbsSyntaxTree where @@ -19,18 +19,20 @@ import System.IO import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Error+import Control.Monad.Trans.Except +import Data.Data (Data)+import Data.Function (on) import Data.List hiding (group) import Data.Char-import qualified Data.Map as M+import qualified Data.Map.Strict as M import qualified Data.Text as T-import qualified Data.Map as M import Data.Either import qualified Data.Set as S import Data.Word (Word) import Data.Maybe (fromMaybe, mapMaybe) import Data.Traversable (Traversable)+import Data.Typeable import Data.Foldable (Foldable) import Debug.Trace@@ -45,16 +47,17 @@ -- rec_elabDecl is used to pass the top level elaborator into other elaborators, -- so that we can have mutually recursive elaborators in separate modules without--- having to much about with cyclic modules.+-- having to muck about with cyclic modules. data ElabInfo = EInfo { params :: [(Name, PTerm)], inblock :: Ctxt [Name], -- names in the block, and their params liftname :: Name -> Name,- namespace :: Maybe [String], + namespace :: Maybe [String],+ elabFC :: Maybe FC, rec_elabDecl :: ElabWhat -> ElabInfo -> PDecl -> Idris () } toplevel :: ElabInfo-toplevel = EInfo [] emptyContext id Nothing (\_ _ _ -> fail "Not implemented")+toplevel = EInfo [] emptyContext id Nothing Nothing (\_ _ _ -> fail "Not implemented") eInfoNames :: ElabInfo -> [Name] eInfoNames info = map fst (params info) ++ M.keys (inblock info)@@ -164,6 +167,9 @@ idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos idris_calledgraph :: Ctxt [Name], idris_docstrings :: Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]),+ idris_moduledocs :: Ctxt (Docstring DocTerm),+ -- ^ module documentation is saved in a special MN so the context+ -- mechanism can be used for disambiguation idris_tyinfodata :: Ctxt TIData, idris_fninfo :: Ctxt FnInfo, idris_transforms :: Ctxt [(Term, Term)],@@ -177,7 +183,7 @@ idris_metavars :: [(Name, (Maybe Name, Int, Bool))], -- ^ The currently defined but not proven metavariables idris_coercions :: [Name], idris_errRev :: [(Term, Term)],- syntax_rules :: [Syntax],+ syntax_rules :: SyntaxRules, syntax_keywords :: [String], imported :: [FilePath], -- ^ The imported modules idris_scprims :: [(Name, (Int, PrimFn))],@@ -185,7 +191,7 @@ idris_libs :: [(Codegen, String)], idris_cgflags :: [(Codegen, String)], idris_hdrs :: [(Codegen, String)],- idris_imported :: [FilePath], -- ^ Imported ibc file names+ idris_imported :: [(FilePath, Bool)], -- ^ Imported ibc file names, whether public proof_list :: [(Name, [String])], errSpan :: Maybe FC, parserWarnings :: [(FC, Err)],@@ -212,7 +218,9 @@ idris_postulates :: S.Set Name, 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+ 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) } -- Required for parsers library, and therefore trifecta@@ -257,7 +265,7 @@ | IBCMetavar Name | IBCSyntax Syntax | IBCKeyword String- | IBCImport FilePath+ | IBCImport (Bool, FilePath) -- True = import public | IBCImportDir FilePath | IBCObj Codegen FilePath | IBCLib Codegen String@@ -282,23 +290,25 @@ | IBCPostulate Name | IBCTotCheckErr FC String | IBCParsedRegion FC+ | IBCModDocs Name -- ^ The name is the special name used to track module docs deriving Show -- | The initial state for the compiler idrisInit :: IState-idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext+idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext- [] [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] []+ emptyContext emptyContext emptyContext emptyContext+ [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] [] [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] [] (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty- AutomaticWidth S.empty Nothing Nothing []+ 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 (ErrorT Err IO)+type Idris = StateT IState (ExceptT Err IO) -- Commands in the REPL @@ -310,6 +320,9 @@ -- | ViaLLVM | Bytecode deriving (Show, Eq)+{-!+deriving instance NFData Codegen+!-} -- | REPL commands data Command = Quit@@ -344,8 +357,7 @@ | DynamicLink FilePath | ListDynamic | Pattelab PTerm- | DebugInfo Name- | Search PTerm+ | Search [String] PTerm | CaseSplitAt Bool Int Name | AddClauseFrom Bool Int Name | AddProofClauseFrom Bool Int Name@@ -363,7 +375,7 @@ | ColourOff | ListErrorHandlers | SetConsoleWidth ConsoleWidth- | Apropos String+ | Apropos [String] String | WhoCalls Name | CallsWho Name | MakeDoc String -- IdrisDoc@@ -371,6 +383,9 @@ | PrintDef Name | PPrint OutputFmt Int PTerm | TransformInfo Name+ -- Debugging commands+ | DebugInfo Name+ | DebugUnify PTerm PTerm data OutputFmt = HTMLOutput | LaTeXOutput @@ -383,6 +398,7 @@ | ShowLibs | ShowLibdir | ShowIncs+ | ShowPkgs | NoBasePkgs | NoPrelude | NoBuiltins -- only for the really primitive stuff!@@ -409,6 +425,7 @@ | PkgREPL String | PkgMkDoc String -- IdrisDoc | PkgTest String+ | PkgIndex FilePath | WarnOnly | Pkg String | BCAsm String@@ -464,7 +481,7 @@ data Static = Static | Dynamic- deriving (Show, Eq)+ deriving (Show, Eq, Data, Typeable) {-! deriving instance Binary Static deriving instance NFData Static@@ -473,7 +490,9 @@ -- Mark bindings with their explicitness, and laziness data Plicity = Imp { pargopts :: [ArgOpt], pstatic :: Static,- pparam :: Bool }+ pparam :: Bool,+ pscoped :: Maybe ImplicitInfo -- Nothing, if top level+ } | Exp { pargopts :: [ArgOpt], pstatic :: Static, pparam :: Bool } -- this is a param (rather than index)@@ -482,14 +501,20 @@ | TacImp { pargopts :: [ArgOpt], pstatic :: Static, pscript :: PTerm }- deriving (Show, Eq)+ deriving (Show, Eq, Data, Typeable) {-! deriving instance Binary Plicity deriving instance NFData Plicity !-} -impl = Imp [] Dynamic False+is_scoped :: Plicity -> Maybe ImplicitInfo+is_scoped (Imp _ _ _ s) = s+is_scoped _ = Nothing++impl = Imp [] Dynamic False Nothing+forall_imp = Imp [] Dynamic False (Just (Impl False))+forall_constraint = Imp [] Dynamic False (Just (Impl True)) expl = Exp [] Dynamic False expl_param = Exp [] Dynamic True constraint = Constraint [] Static@@ -552,14 +577,14 @@ | PNamespace String [PDecl' t] -- ^ New namespace | PRecord (Docstring (Either Err PTerm)) SyntaxInfo FC Name t DataOpts (Docstring (Either Err PTerm)) Name t -- ^ Record declaration | PClass (Docstring (Either Err PTerm)) SyntaxInfo FC- [t] -- constraints+ [(Name, t)] -- constraints Name [(Name, t)] -- parameters [(Name, Docstring (Either Err PTerm))] -- parameter docstrings [PDecl' t] -- declarations -- ^ Type class: arguments are documentation, syntax info, source location, constraints, -- class name, parameters, method declarations- | PInstance SyntaxInfo FC [t] -- constraints+ | PInstance SyntaxInfo FC [(Name, t)] -- constraints Name -- class [t] -- parameters t -- full instance type@@ -581,8 +606,15 @@ !-} -- For elaborator state-type ElabD a = Elab' [PDecl] a+data EState = EState {+ case_decls :: [PDecl],+ delayed_elab :: [Elab' EState ()]+ } +initEState = EState [] []++type ElabD a = Elab' EState a+ -- | One clause of a top-level definition. Term arguments to constructors are: -- -- 1. The whole application (missing for PClauseR and PWithR because they're within a "with" clause)@@ -702,16 +734,16 @@ -- (map (updateDNs ns) ds) -- updateDNs ns c = c -data PunInfo = IsType | IsTerm | TypeOrTerm deriving (Eq, Show)+data PunInfo = IsType | IsTerm | TypeOrTerm deriving (Eq, Show, Data, Typeable) -- | High level language terms data PTerm = PQuote Raw -- ^ Inclusion of a core term into the high-level language | PRef FC Name -- ^ A reference to a variable | PInferRef FC Name -- ^ A name to be defined later | PPatvar FC Name -- ^ A pattern variable- | PLam Name PTerm PTerm -- ^ A lambda abstraction+ | PLam FC Name PTerm PTerm -- ^ A lambda abstraction | PPi Plicity Name PTerm PTerm -- ^ (n : t1) -> t2- | PLet Name PTerm PTerm PTerm -- ^ A let binding+ | 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 | PAppBind FC PTerm [PArg] -- ^ implicitly bound application@@ -724,6 +756,7 @@ | PRewrite FC PTerm PTerm (Maybe PTerm) -- ^ "rewrite" syntax, with optional result type | PPair FC PunInfo PTerm PTerm -- ^ A pair (a, b) and whether it's a product type or a pair (solved by elaboration) | PDPair FC PunInfo PTerm PTerm PTerm -- ^ A dependent pair (tm : a ** b) and whether it's a sigma type or a pair that inhabits one (solved by elaboration)+ | PAs FC Name PTerm -- ^ @-pattern, valid LHS only | PAlternative Bool [PTerm] -- ^ True if only one may work. (| A, B, C|) | PHidden PTerm -- ^ Irrelevant or hidden pattern | PType -- ^ 'Type' type@@ -745,7 +778,7 @@ | PNoImplicits PTerm -- ^ never run implicit converions on the term | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term]) | PUnquote PTerm -- ^ ,Term- deriving Eq+ deriving (Eq, Data, Typeable) {-!@@ -755,9 +788,9 @@ mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm mapPT f t = f (mpt t) where- mpt (PLam n t s) = PLam n (mapPT f t) (mapPT f s)+ mpt (PLam fc n t s) = PLam fc n (mapPT f t) (mapPT f s) mpt (PPi p n t s) = PPi p n (mapPT f t) (mapPT f s)- mpt (PLet n ty v s) = PLet n (mapPT f ty) (mapPT f v) (mapPT f s)+ mpt (PLet fc n ty v s) = PLet fc n (mapPT f ty) (mapPT f v) (mapPT f s) mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s) (fmap (mapPT f) g) mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)@@ -806,7 +839,8 @@ | Skip | TFail [ErrorReportPart] | Qed | Abandon- deriving (Show, Eq, Functor, Foldable, Traversable)+ | SourceFC+ deriving (Show, Eq, Functor, Foldable, Traversable, Data, Typeable) {-! deriving instance Binary PTactic' deriving instance NFData PTactic'@@ -836,6 +870,7 @@ size Abandon = 1 size Skip = 1 size (TFail ts) = 1 + size ts+ size SourceFC = 1 type PTactic = PTactic' PTerm @@ -844,7 +879,7 @@ | DoBindP FC t t [(t,t)] | DoLet FC Name t t | DoLetP FC t t- deriving (Eq, Functor)+ deriving (Eq, Functor, Data, Typeable) {-! deriving instance Binary PDo' deriving instance NFData PDo'@@ -880,10 +915,10 @@ pname :: Name, getScript :: t, getTm :: t }- deriving (Show, Eq, Functor)+ deriving (Show, Eq, Functor, Data, Typeable) data ArgOpt = AlwaysShow | HideDisplay | InaccessibleArg- deriving (Show, Eq)+ deriving (Show, Eq, Data, Typeable) instance Sized a => Sized (PArg' a) where size (PImp p _ l nm trm) = 1 + size nm + size trm@@ -928,6 +963,7 @@ deriving Show {-! deriving instance Binary FnInfo+deriving instance NFData FnInfo !-} data OptInfo = Optimise { inaccessible :: [(Int,Name)], -- includes names for error reporting@@ -985,6 +1021,9 @@ syntaxNames (Rule syms _ _) = mapMaybe ename syms where ename (Keyword n) = Just n ename _ = Nothing++syntaxSymbols :: Syntax -> [SSymbol]+syntaxSymbols (Rule ss _ _) = ss {-! deriving instance Binary Syntax deriving instance NFData Syntax@@ -995,7 +1034,7 @@ | Binding Name | Expr Name | SimpleExpr Name- deriving Show+ deriving (Show, Eq) {-!@@ -1003,6 +1042,46 @@ deriving instance NFData SSymbol !-} +newtype SyntaxRules = SyntaxRules { syntaxRulesList :: [Syntax] }++emptySyntaxRules :: SyntaxRules+emptySyntaxRules = SyntaxRules []++updateSyntaxRules :: [Syntax] -> SyntaxRules -> SyntaxRules+updateSyntaxRules rules (SyntaxRules sr) = SyntaxRules newRules+ where+ newRules = sortBy (ruleSort `on` syntaxSymbols) (rules ++ sr)++ ruleSort [] [] = EQ+ ruleSort [] _ = LT+ ruleSort _ [] = GT+ ruleSort (s1:ss1) (s2:ss2) =+ case symCompare s1 s2 of+ EQ -> ruleSort ss1 ss2+ r -> r++ -- Better than creating Ord instance for SSymbol since+ -- in general this ordering does not really make sense.+ symCompare (Keyword n1) (Keyword n2) = compare n1 n2+ symCompare (Keyword _) _ = LT+ symCompare (Symbol _) (Keyword _) = GT+ symCompare (Symbol s1) (Symbol s2) = compare s1 s2+ symCompare (Symbol _) _ = LT+ symCompare (Binding _) (Keyword _) = GT+ symCompare (Binding _) (Symbol _) = GT+ symCompare (Binding b1) (Binding b2) = compare b1 b2+ symCompare (Binding _) _ = LT+ symCompare (Expr _) (Keyword _) = GT+ symCompare (Expr _) (Symbol _) = GT+ symCompare (Expr _) (Binding _) = GT+ symCompare (Expr e1) (Expr e2) = compare e1 e2+ symCompare (Expr _) _ = LT+ symCompare (SimpleExpr _) (Keyword _) = GT+ symCompare (SimpleExpr _) (Symbol _) = GT+ symCompare (SimpleExpr _) (Binding _) = GT+ symCompare (SimpleExpr _) (Expr _) = GT+ symCompare (SimpleExpr e1) (SimpleExpr e2) = compare e1 e2+ initDSL = DSL (PRef f (sUN ">>=")) (PRef f (sUN "return")) (PRef f (sUN "<$>"))@@ -1071,7 +1150,7 @@ getInferTerm tm = tm -- error ("getInferTerm " ++ show tm) getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc- where toTy (Lam t) = Pi t (TType (UVar 0))+ where toTy (Lam t) = Pi Nothing t (TType (UVar 0)) toTy (PVar t) = PVTy t toTy b = b getInferType (App (App _ ty) _) = ty@@ -1092,8 +1171,8 @@ "of type `Void` in scope." falseTy = sUN "Void" -pairTy = sUN "Pair"-pairCon = sUN "MkPair"+pairTy = sNS (sUN "Pair") ["Builtins"]+pairCon = sNS (sUN "MkPair") ["Builtins"] eqTy = sUN "=" eqCon = sUN "Refl"@@ -1133,9 +1212,15 @@ eqOpts = [] +-- | The special name to be used in the module documentation context -+-- not for use in the main definition context. The namespace around it+-- will determine the module to which the docs adhere.+modDocName :: Name+modDocName = sMN 0 "ModuleDocs"+ -- Defined in builtins.idr-sigmaTy = sUN "Sigma"-existsCon = sUN "MkSigma"+sigmaTy = sNS (sUN "Sigma") ["Builtins"]+existsCon = sNS (sUN "MkSigma") ["Builtins"] piBind :: [(Name, PTerm)] -> PTerm -> PTerm piBind = piBindp expl@@ -1218,8 +1303,10 @@ -> [FixDecl] -- ^^ Fixity declarations -> PTerm -- ^^ the term to pretty-print -> Doc OutputAnnotation-pprintPTerm ppo bnd docArgs infixes = prettySe 10 bnd+pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd where+ startPrec = 0+ funcAppPrec = 10 prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation prettySe p bnd (PQuote r) = text "![" <> pretty r <> text "]"@@ -1228,45 +1315,45 @@ | Just str <- slist p bnd e = str | Just n <- snat p e = annotate (AnnData "Nat" "") (text (show n)) prettySe p bnd (PRef fc n) = prettyName True (ppopt_impl ppo) bnd n- prettySe p bnd (PLam n ty sc) =- bracket p 2 . group . align . hang 2 $+ prettySe p bnd (PLam fc n ty sc) =+ bracket p startPrec . group . align . hang 2 $ text "\\" <> bindingOf n False <+> text "=>" <$>- prettySe 10 ((n, False):bnd) sc- prettySe p bnd (PLet n ty v sc) =- bracket p 2 . group . align $- kwd "let" <+> (group . align . hang 2 $ bindingOf n False <+> text "=" <$> prettySe 10 bnd v) </>- kwd "in" <+> (group . align . hang 2 $ prettySe 10 ((n, False):bnd) sc)+ prettySe startPrec ((n, False):bnd) sc+ prettySe p bnd (PLet fc n ty v sc) =+ bracket p startPrec . group . align $+ kwd "let" <+> (group . align . hang 2 $ bindingOf n False <+> text "=" <$> prettySe startPrec bnd v) </>+ kwd "in" <+> (group . align . hang 2 $ prettySe startPrec ((n, False):bnd) sc) prettySe p bnd (PPi (Exp l s _) n ty sc) | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs =- bracket p 2 . group $- enclose lparen rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>- st <> text "->" <$> prettySe 10 ((n, False):bnd) sc+ bracket p startPrec . group $+ enclose lparen rparen (group . align $ bindingOf n False <+> colon <+> prettySe startPrec bnd ty) <+>+ st <> text "->" <$> prettySe startPrec ((n, False):bnd) sc | otherwise =- bracket p 2 . group $- group (prettySe 1 bnd ty <+> st) <> text "->" <$> group (prettySe 10 ((n, False):bnd) sc)+ bracket p startPrec . group $+ group (prettySe (startPrec + 1) bnd ty <+> st) <> text "->" <$> group (prettySe startPrec ((n, False):bnd) sc) where st = case s of Static -> text "[static]" <> space _ -> empty- prettySe p bnd (PPi (Imp l s _) n ty sc)+ prettySe p bnd (PPi (Imp l s _ fa) n ty sc) | ppopt_impl ppo =- bracket p 2 $- lbrace <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+>- st <> text "->" </> prettySe 10 ((n, True):bnd) sc- | otherwise = prettySe 10 ((n, True):bnd) sc+ bracket p startPrec $+ lbrace <> bindingOf n True <+> colon <+> prettySe startPrec bnd ty <> rbrace <+>+ st <> text "->" </> prettySe startPrec ((n, True):bnd) sc+ | otherwise = prettySe startPrec ((n, True):bnd) sc where st = case s of Static -> text "[static]" <> space _ -> empty prettySe p bnd (PPi (Constraint _ _) n ty sc) =- bracket p 2 $- prettySe 10 bnd ty <+> text "=>" </> prettySe 10 ((n, True):bnd) sc+ bracket p startPrec $+ prettySe (startPrec + 1) bnd ty <+> text "=>" </> prettySe startPrec ((n, True):bnd) sc prettySe p bnd (PPi (TacImp _ _ s) n ty sc) =- bracket p 2 $- lbrace <> kwd "tacimp" <+> pretty n <+> colon <+> prettySe 10 bnd ty <>- rbrace <+> text "->" </> prettySe 10 ((n, True):bnd) sc+ bracket p startPrec $+ lbrace <> kwd "tacimp" <+> pretty n <+> colon <+> prettySe startPrec bnd ty <>+ rbrace <+> text "->" </> prettySe startPrec ((n, True):bnd) sc prettySe p bnd (PApp _ (PRef _ f) args) -- normal names, no explicit args | UN nm <- basename f , not (ppopt_impl ppo) && null (getShowArgs args) =@@ -1279,49 +1366,63 @@ (not (ppopt_impl ppo)) && (not $ isAlpha (thead nm)) = case getShowArgs args of [] -> opName True- [x] -> group (opName True <$> group (prettySe 0 bnd (getTm x)))- [l,r] -> let precedence = fromMaybe 20 (fmap prec f)+ [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) -> - bracket p 1 $+ bracket p funcAppPrec $ enclose lparen rparen (inFix (getTm l) (getTm r)) <+> align (group (vsep (map (prettyArgS bnd) rest))) as -> opName True <+> align (vsep (map (prettyArgS bnd) as)) where opName isPrefix = prettyName isPrefix (ppopt_impl ppo) bnd op f = getFixity (opStr op)- left l = case f of- Nothing -> prettySe (-1) bnd l- Just (Infixl p') -> prettySe p' bnd l- Just f' -> prettySe (prec f'-1) bnd l- right r = case f of- Nothing -> prettySe (-1) bnd r- Just (Infixr p') -> prettySe p' bnd r- Just f' -> prettySe (prec f'-1) bnd r+ left = case f of+ Nothing -> funcAppPrec + 1+ Just (Infixl p') -> p'+ Just f' -> prec f' + 1+ right = case f of+ Nothing -> funcAppPrec + 1+ Just (Infixr p') -> p'+ Just f' -> prec f' + 1 inFix l r = align . group $- (left l <+> opName False) <$> group (right r)+ (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, f == sUN "Symbol_" = annotate (AnnType ("'" ++ str) ("The symbol " ++ str)) $- char '\'' <> prettySe 10 bnd (PRef fc (sUN str))+ char '\'' <> prettySe startPrec bnd (PRef fc (sUN str)) prettySe p bnd (PApp _ f as) = -- Normal prefix applications let args = getShowArgs as- fp = prettySe 1 bnd f+ fp = prettySe (startPrec + 1) bnd f+ shownArgs = if ppopt_impl ppo then as else args in- bracket p 1 . group $- if ppopt_impl ppo- then if null as- then fp- else fp <+> align (vsep (map (prettyArgS bnd) as))- else if null args- then fp- else fp <+> align (vsep (map (prettyArgS bnd) args))- prettySe p bnd (PCase _ scr opts) =- kwd "case" <+> prettySe 10 bnd scr <+> kwd "of" <> prettyBody+ bracket p funcAppPrec . group $+ if null shownArgs+ then fp+ else fp <+> align (vsep (map (prettyArgS bnd) shownArgs))+ prettySe p bnd (PCase _ scr cases) =+ align $ kwd "case" <+> prettySe startPrec bnd scr <+> kwd "of" <$>+ indent 2 (vsep (map ppcase cases)) where- prettyBody = foldr (<>) empty $ intersperse (text "|") $ map sc opts+ ppcase (l, r) = let prettyCase = prettySe startPrec + ([(n, False) | n <- vars l] ++ bnd)+ in nest nestingSize $+ prettyCase l <+> text "=>" <+> prettyCase r+ -- Warning: this is a bit of a hack. At this stage, we don't have the+ -- global context, so we can't determine which names are constructors,+ -- which are types, and which are pattern variables on the LHS of the+ -- case pattern. We use the heuristic that names without a namespace+ -- are patvars, because right now case blocks in PTerms are always+ -- delaborated from TT before being sent to the pretty-printer. If they+ -- start getting printed directly, THIS WILL BREAK.+ -- Potential solution: add a list of known patvars to the cases in+ -- PCase, and have the delaborator fill it out, kind of like the pun+ -- disambiguation on PDPair.+ vars tm = filter noNS (allNamesIn tm)+ noNS (NS _ _) = False+ noNS _ = True - sc (l, r) = nest nestingSize $ prettySe 10 bnd l <+> text "=>" <+> prettySe 10 bnd r- prettySe p bnd (PHidden tm) = text "." <> prettySe 0 bnd tm+ prettySe p bnd (PHidden tm) = text "." <> prettySe funcAppPrec bnd tm prettySe p bnd (PRefl _ _) = annName eqCon $ text "Refl" prettySe p bnd (PResolveTC _) = text "resolvetc" prettySe p bnd (PTrue _ IsType) = annName unitTy $ text "()"@@ -1329,7 +1430,7 @@ prettySe p bnd (PTrue _ TypeOrTerm) = text "()" prettySe p bnd (PEq _ lt rt l r) | ppopt_impl ppo =- bracket p 1 $+ bracket p eqPrec $ enclose lparen rparen eq <+> align (group (vsep (map (prettyArgS bnd) [PImp 0 False [] (sUN "A") lt,@@ -1337,47 +1438,42 @@ PExp 0 [] (sUN "x") l, PExp 0 [] (sUN "y") r]))) | otherwise =- bracket p 2 . align . group $- prettySe 10 bnd l <+> eq <$> group (prettySe 10 bnd r)+ bracket p eqPrec . align . group $+ prettyTerm l <+> eq <$> group (prettyTerm r) where eq = annName eqTy (text "=")+ eqPrec = startPrec+ prettyTerm = prettySe (eqPrec + 1) bnd prettySe p bnd (PRewrite _ l r _) =- bracket p 2 $- text "rewrite" <+> prettySe 10 bnd l <+> text "in" <+> prettySe 10 bnd r+ bracket p startPrec $+ text "rewrite" <+> prettySe (startPrec + 1) bnd l <+> text "in" <+> prettySe startPrec bnd r prettySe p bnd (PTyped l r) =- lparen <> prettySe 10 bnd l <+> colon <+> prettySe 10 bnd r <> rparen+ lparen <> prettySe startPrec bnd l <+> colon <+> prettySe startPrec bnd r <> rparen prettySe p bnd pair@(PPair _ pun _ _) -- flatten tuples to the right, like parser | Just elts <- pairElts pair = enclose (ann lparen) (ann rparen) . align . group . vsep . punctuate (ann comma) $- map (prettySe 10 bnd) elts+ map (prettySe startPrec bnd) elts where ann = case pun of TypeOrTerm -> id IsType -> annName pairTy IsTerm -> annName pairCon- prettySe p bnd (PDPair _ TypeOrTerm l t r) =- lparen <> prettySe 10 bnd l <+> text "**" <+> prettySe 10 bnd r <> rparen- prettySe p bnd (PDPair _ IsType (PRef _ n) t r) =- annName sigmaTy lparen <>- bindingOf n False <+>- annName sigmaTy (text "**") <+>- prettySe 10 ((n, False):bnd) r <>- annName sigmaTy rparen- prettySe p bnd (PDPair _ IsType l t r) =- annName sigmaTy lparen <>- prettySe 10 bnd l <+>- annName sigmaTy (text "**") <+>- prettySe 10 bnd r <>- annName sigmaTy rparen- prettySe p bnd (PDPair _ IsTerm l t r) =- annName existsCon lparen <>- prettySe 10 bnd l <+>- annName existsCon (text "**") <+>- prettySe 10 bnd r <>- annName existsCon rparen+ prettySe p bnd (PDPair _ pun l t r) =+ annotated lparen <>+ left <+>+ annotated (text "**") <+>+ prettySe startPrec (addBinding bnd) r <>+ annotated rparen+ where annotated = case pun of+ IsType -> annName sigmaTy+ IsTerm -> annName existsCon+ TypeOrTerm -> id+ (left, addBinding) = case (l, pun) of+ (PRef _ n, IsType) -> (bindingOf n False, ((n, False) :))+ _ -> (prettySe startPrec bnd l, id ) prettySe p bnd (PAlternative a as) = lparen <> text "|" <> prettyAs <> text "|" <> rparen where prettyAs =- foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe 10 bnd) as+ 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 (PConstant c) = annotate (AnnConst c) (text (show c))@@ -1405,10 +1501,10 @@ prettyArgS bnd (PConstraint _ _ _ tm) = prettyArgSc bnd tm prettyArgS bnd (PTacImplicit _ _ n _ tm) = prettyArgSti bnd (n, tm) - prettyArgSe bnd arg = prettySe 0 bnd arg- prettyArgSi bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace- prettyArgSc bnd val = lbrace <> lbrace <> prettySe 10 bnd val <> rbrace <> rbrace- prettyArgSti bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace+ prettyArgSe bnd arg = prettySe (funcAppPrec + 1) bnd arg+ prettyArgSi bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe startPrec bnd val <> rbrace+ prettyArgSc bnd val = lbrace <> lbrace <> prettySe startPrec bnd val <> rbrace <> rbrace+ prettyArgSti bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe startPrec bnd val <> rbrace annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation annName n = annotate (AnnName n Nothing Nothing Nothing)@@ -1465,7 +1561,7 @@ snat _ _ = Nothing bracket outer inner doc- | inner > outer = lparen <> doc <> rparen+ | outer > inner = lparen <> doc <> rparen | otherwise = doc kwd = annotate AnnKeyword . text@@ -1489,13 +1585,15 @@ -> [(Name, Bool)] -- ^^ the current bound variables and whether they are implicit -> Name -- ^^ the name to pprint -> Doc OutputAnnotation-prettyName infixParen showNS bnd n +prettyName infixParen showNS bnd n+ | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_"+ | (UN n') <- n, isPrefixOf "_" $ 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)) baseName (UN n) = T.unpack n baseName (NS n ns) = baseName n- baseName (MN i s) = T.unpack s + baseName (MN i s) = T.unpack s baseName other = show other nameSpace = case n of (NS n' ns) -> if showNS then (concatMap (++ ".") . map T.unpack . reverse) ns else ""@@ -1617,9 +1715,9 @@ instance Sized PTerm where size (PQuote rawTerm) = size rawTerm size (PRef fc name) = size name- size (PLam name ty bdy) = 1 + size ty + size bdy+ size (PLam fc name ty bdy) = 1 + size ty + size bdy size (PPi plicity name ty bdy) = 1 + size ty + size bdy- size (PLet name ty def bdy) = 1 + size ty + size def + size bdy+ size (PLet fc name ty def bdy) = 1 + size ty + size def + size bdy size (PTyped trm ty) = 1 + size trm + size ty size (PApp fc name args) = 1 + size args size (PAppBind fc name args) = 1 + size args@@ -1664,7 +1762,7 @@ ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)- ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc+ ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc ni env (PHidden tm) = ni env tm ni env (PEq _ _ _ l r) = ni env l ++ ni env r@@ -1689,8 +1787,8 @@ ni (PApp _ f as) = ni f ++ concatMap (ni) (map getTm as) ni (PAppBind _ f as) = ni f ++ concatMap (ni) (map getTm as) ni (PCase _ c os) = ni c ++ concatMap (ni) (map snd os)- ni (PLam n ty sc) = n : (ni ty ++ ni sc)- ni (PLet n ty val sc) = n : (ni ty ++ ni val ++ ni sc)+ ni (PLam fc n ty sc) = n : (ni ty ++ ni sc)+ ni (PLet fc n ty val sc) = n : (ni ty ++ ni val ++ ni sc) ni (PPi p n ty sc) = niTacImp p ++ (n : (ni ty ++ ni sc)) ni (PEq _ _ _ l r) = ni l ++ ni r ni (PRewrite _ l r _) = ni l ++ ni r@@ -1726,7 +1824,7 @@ -- names in 'os', not counting the names bound in the cases (nub (concatMap (ni env) (map snd os)) \\ nub (concatMap (ni env) (map fst os)))- ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc+ ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi p n ty sc) = ni env ty ++ ni (n:env) sc ni env (PEq _ _ _ l r) = ni env l ++ ni env r ni env (PRewrite _ l r _) = ni env l ++ ni env r@@ -1756,7 +1854,7 @@ -- names in 'os', not counting the names bound in the cases (nub (concatMap (ni env) (map snd os)) \\ nub (concatMap (ni env) (map fst os)))- ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc+ ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc ni env (PEq _ _ _ l r) = ni env l ++ ni env r ni env (PRewrite _ l r _) = ni env l ++ ni env r@@ -1787,7 +1885,7 @@ ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)- ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc+ ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc ni env (PEq _ _ _ l r) = ni env l ++ ni env r ni env (PRewrite _ l r _) = ni env l ++ ni env r
src/Idris/Apropos.hs view
@@ -1,12 +1,12 @@-module Idris.Apropos where+module Idris.Apropos (apropos, aproposModules) where import Idris.AbsSyntax import Idris.Core.Evaluate (ctxtAlist, Def(..)) import Idris.Core.TT (Name(..), Type, TT(..), NameType(..), Binder(..), Const(..), lookupCtxtExact, toAlist)-import Idris.Docstrings (Docstring, containsText)+import Idris.Docstrings (Docstring, DocTerm, containsText) -import Data.List (nub)+import Data.List (nub, nubBy, intersperse) import qualified Data.Text as T -- | Find definitions that are relevant to all space-delimited components of@@ -22,11 +22,25 @@ docs = toAlist (idris_docstrings ist) in nub (map fst (isAproposAll parts defs) ++ map fst (isAproposAll parts docs))- where isAproposAll [] xs = xs+ where isAproposAll [] xs = xs isAproposAll (what:more) xs = filter (isApropos what) (isAproposAll more xs) parts = filter ((> 0) . T.length) . T.splitOn (T.pack " ") $ what +-- | Find modules whose names or docstrings contain all the+-- space-delimited components of some string.+aproposModules :: IState -> T.Text -> [(String, Docstring DocTerm)]+aproposModules ist what = let mods = toAlist (idris_moduledocs ist)+ found = nubBy (\x y -> fst x == fst y)+ (isAproposAll parts mods)+ in map unModName found+ where isAproposAll [] xs = xs+ isAproposAll (what:more) xs = filter (\(n,d) -> isApropos what n || isApropos what d)+ (isAproposAll more xs)+ parts = filter ((> 0) . T.length) . T.splitOn (T.pack " ") $ what+ unModName (NS _ ns, d) = ((concat . intersperse "." . map T.unpack . reverse) ns, d)+ unModName (n, d) = ("<<MODULE>>", d)+ textIn :: T.Text -> T.Text -> Bool textIn a b = T.isInfixOf (T.toLower a) (T.toLower b) @@ -52,7 +66,7 @@ instance Apropos (Binder (TT Name)) where isApropos str (Lam ty) = str == T.pack "\\" || isApropos str ty- isApropos str (Pi ty _) = str == T.pack "->" || isApropos str ty+ isApropos str (Pi _ ty _) = str == T.pack "->" || isApropos str ty isApropos str (Let ty val) = str == T.pack "let" || isApropos str ty || isApropos str val isApropos str (NLet ty val) = str == T.pack "let" || isApropos str ty || isApropos str val isApropos str _ = False -- these shouldn't occur in defined libraries
src/Idris/CaseSplit.hs view
@@ -57,7 +57,9 @@ = do ist <- getIState -- Make sure all the names in the term are accessible mapM_ (\n -> setAccessibility n Public) (allNamesIn t')- (tm, ty, pats) <- elabValBind recinfo ELHS True (addImplPat ist t')+ -- ETyDecl rather then ELHS because there'll be explicit type+ -- matching+ (tm, ty, pats) <- elabValBind recinfo ETyDecl True (addImplPat ist t') -- ASSUMPTION: tm is in normal form after elabValBind, so we don't -- need to do anything special to find out what family each argument -- is in@@ -181,7 +183,7 @@ = case lookupTy n (tt_ctxt ist) of [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing _ -> repeat Nothing- where tyName (Bind _ (Pi _ _) _) = Just (sUN "->")+ where tyName (Bind _ (Pi _ _ _) _) = Just (sUN "->") tyName t | (P _ n _, _) <- unApply t = Just n | otherwise = Nothing argTys _ _ = repeat Nothing@@ -359,7 +361,7 @@ getNameFrom i used (PPi _ _ _ _) = uniqueNameFrom (mkSupply [sUN "f", sUN "g"]) used getNameFrom i used (PApp fc f as) = getNameFrom i used f- getNameFrom i used (PEq _ _ _ _ _) = uniqueNameFrom [sUN "prf"] used + getNameFrom i used (PEq _ _ _ _ _) = uniqueNameFrom (mkSupply [sUN "prf"]) used getNameFrom i used (PRef fc f) = case getNameHints i f of [] -> uniqueName (sUN "x") used
src/Idris/Chaser.hs view
@@ -126,7 +126,7 @@ if exist then do ibct <- runIO $ getModificationTime ibc srct <- runIO $ getModificationTime src- return (srct > ibct)+ return (srct >= ibct) else return False children :: Bool -> FilePath -> [FilePath] -> Idris [ModuleTree]@@ -135,10 +135,10 @@ if exist then do file_in <- runIO $ readFile f file <- if lit then tclift $ unlit f file_in else return file_in- (_, modules, _) <- parseImports f file+ (_, _, modules, _) <- parseImports f file -- The chaser should never report warnings from sub-modules clearParserWarnings- ms <- mapM (btree done) [realName | (realName, alias, fc) <- modules]+ ms <- mapM (btree done) [realName | (_, realName, alias, fc) <- modules] return (concat ms) else return [] -- IBC with no source available -- (\c -> return []) -- error, can't chase modules here
src/Idris/CmdOptions.hs view
@@ -23,7 +23,8 @@ return $ preProcOpts opts [] where idrisHeader = PP.hsep [PP.text "Idris version", PP.text ver, PP.text ", (C) The Idris Community 2014"]- idrisProgDesc = PP.vsep [PP.text "Idris is a general purpose pure functional programming language with dependent",+ 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 "It is compiled, with eager evaluation. Its features are influenced by Haskell",@@ -43,8 +44,7 @@ "+ Cumulative universes", "+ Simple foreign function interface (to C)", "+ Hugs style interactive environment"- ],- PP.empty]+ ]] idrisFooter = PP.vsep [PP.text "It is important to note that Idris is first and foremost a research tool", PP.text "and project. Thus the tooling provided and resulting programs created", PP.text "should not necessarily be seen as production ready nor for industrial use.",@@ -75,12 +75,12 @@ <|> flag' IdeslaveSocket (long "ideslave-socket") <|> (Client <$> strOption (long "client")) <|> (OLogging <$> option auto (long "log" <> metavar "LEVEL" <> help "Debugging log level"))- <|> flag' NoBasePkgs (long "nobasepkgs")- <|> flag' NoPrelude (long "noprelude")- <|> flag' NoBuiltins (long "nobuiltins")+ <|> flag' NoBasePkgs (long "nobasepkgs" <> help "Do not use the given base package")+ <|> flag' NoPrelude (long "noprelude" <> help "Do not use the given prelude")+ <|> flag' NoBuiltins (long "nobuiltins" <> help "Do not use the builtin functions") <|> flag' NoREPL (long "check" <> help "Typecheck only, don't start the REPL") <|> (Output <$> strOption (short 'o' <> long "output" <> metavar "FILE" <> help "Specify output file"))--- <|> flag' TypeCase (long "typecase")+ -- <|> flag' TypeCase (long "typecase") <|> flag' TypeInType (long "typeintype") <|> flag' DefaultTotal (long "total" <> help "Require functions to be total by default") <|> flag' DefaultPartial (long "partial")@@ -89,18 +89,19 @@ <|> flag' NoCoverage (long "nocoverage") <|> flag' ErrContext (long "errorcontext") <|> flag' ShowLibs (long "link" <> help "Display link flags")+ <|> flag' ShowPkgs (long "listlibs" <> help "Display installed libraries") <|> flag' ShowLibdir (long "libdir" <> help "Display library directory") <|> flag' ShowIncs (long "include" <> help "Display the includes flags") <|> flag' Verbose (short 'V' <> long "verbose" <> help "Loud verbosity") <|> (IBCSubDir <$> strOption (long "ibcsubdir" <> metavar "FILE" <> help "Write IBC files into sub directory")) <|> (ImportDir <$> strOption (short 'i' <> long "idrispath" <> help "Add directory to the list of import paths")) <|> flag' WarnOnly (long "warn")- <|> (Pkg <$> strOption (short 'p' <> long "package"))+ <|> (Pkg <$> strOption (short 'p' <> long "package" <> help "Add package as a dependency")) <|> (Port <$> strOption (long "port" <> metavar "PORT" <> help "REPL TCP port")) -- Package commands <|> (PkgBuild <$> strOption (long "build" <> metavar "IPKG" <> help "Build package")) <|> (PkgInstall <$> strOption (long "install" <> metavar "IPKG" <> help "Install package"))- <|> (PkgREPL <$> strOption (long "repl"))+ <|> (PkgREPL <$> strOption (long "repl" <> metavar "IPKG" <> help "Launch REPL, only for executables")) <|> (PkgClean <$> strOption (long "clean" <> metavar "IPKG" <> help "Clean package")) <|> (PkgMkDoc <$> strOption (long "mkdoc" <> metavar "IPKG" <> help "Generate IdrisDoc for package")) <|> (PkgCheck <$> strOption (long "checkpkg" <> metavar "IPKG" <> help "Check package only"))@@ -122,7 +123,7 @@ <|> flag' (OptLevel 1) (long "O1") <|> flag' (OptLevel 0) (long "O0") <|> flag' (AddOpt PETransform) (long "partial-eval")- <|> flag' (RemoveOpt PETransform) (long "no-partial-eval")+ <|> flag' (RemoveOpt PETransform) (long "no-partial-eval" <> help "Switch off partial evaluation, mainly for debugging purposes") <|> (OptLevel <$> option auto (short 'O' <> long "level")) <|> (TargetTriple <$> strOption (long "target" <> metavar "TRIPLE" <> help "Select target triple (for llvm codegen)")) <|> (TargetCPU <$> strOption (long "cpu" <> metavar "CPU" <> help "Select target CPU e.g. corei7 or cortex-m3 (for LLVM codegen)"))
src/Idris/Colours.hs view
@@ -52,6 +52,17 @@ fg Nothing = [] fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c] +-- | Set the colour of a string using POSIX escape codes, with trailing '\STX' denoting the end+-- (required by Haskeline in the prompt string)+colouriseWithSTX :: IdrisColour -> String -> String+colouriseWithSTX (IdrisColour c v u b i) str = setSGRCode sgr ++ "\STX" ++ str ++ setSGRCode [Reset] ++ "\STX"+ where sgr = fg c +++ (if u then [SetUnderlining SingleUnderline] else []) +++ (if b then [SetConsoleIntensity BoldIntensity] else []) +++ (if i then [SetItalicized True] else [])+ fg Nothing = []+ fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]+ colouriseKwd :: ColourTheme -> String -> String colouriseKwd t = colourise (keywordColour t) @@ -71,7 +82,7 @@ colouriseData t = colourise (dataColour t) colourisePrompt :: ColourTheme -> String -> String-colourisePrompt t = colourise (promptColour t)+colourisePrompt t = colouriseWithSTX (promptColour t) colouriseKeyword :: ColourTheme -> String -> String colouriseKeyword t = colourise (keywordColour t)
src/Idris/Completion.hs view
@@ -4,11 +4,15 @@ import Idris.Core.Evaluate (ctxtAlist) import Idris.Core.TT +import Idris.AbsSyntax (runIO) import Idris.AbsSyntaxTree import Idris.Help+import Idris.Imports (installedPackages) import Idris.Colours import Idris.ParseHelpers(opChars)-+import qualified Idris.ParseExpr (constants, tactics)+import Idris.ParseExpr (TacticArg (..))+import Idris.REPLParser (allHelp) import Control.Monad.State.Strict import Data.List@@ -19,41 +23,11 @@ import System.Console.ANSI (Color) -fst3 :: (a, b, c) -> a-fst3 (a, b, c) = a--commands = concatMap fst3 (help ++ extraHelp)---- | A specification of the arguments that tactics can take-data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n- | ExprTArg- | AltsTArg+commands = [ n | (names, _, _) <- allHelp ++ extraHelp, n <- names ] --- | A list of available tactics and their argument requirements tacticArgs :: [(String, Maybe TacticArg)]-tacticArgs = [ ("intro", Nothing) -- FIXME syntax for intro (fresh name)- , ("refine", Just ExprTArg)- , ("mrefine", Just ExprTArg)- , ("rewrite", Just ExprTArg)- , ("let", Nothing) -- FIXME syntax for let- , ("focus", Just ExprTArg)- , ("exact", Just ExprTArg)- , ("equiv", Just ExprTArg)- , ("applyTactic", Just ExprTArg)- , ("byReflection", Just ExprTArg)- , ("reflect", Just ExprTArg)- , ("fill", Just ExprTArg)- , ("try", Just AltsTArg)- , ("induction", Just ExprTArg)- , ("case", Just ExprTArg)- , (":t", Just ExprTArg)- , (":type", Just ExprTArg)- , (":e", Just ExprTArg)- , (":eval", Just ExprTArg)- ] ++ map (\x -> (x, Nothing)) [- "intros", "compute", "trivial", "search", "solve", "attack",- "unify", "state", "term", "undo", "qed", "abandon", ":q"- ]+tacticArgs = [ (name, args) | (names, args, _) <- Idris.ParseExpr.tactics+ , name <- names ] tactics = map fst tacticArgs -- | Convert a name into a string usable for completion. Filters out names@@ -66,16 +40,15 @@ nameString _ = Nothing -- FIXME: Respect module imports+-- Issue #1767 in the issue tracker.+-- https://github.com/idris-lang/Idris-dev/issues/1767 -- | Get the user-visible names from the current interpreter state. names :: Idris [String] names = do i <- get let ctxt = tt_ctxt i return . nub $ mapMaybe (nameString . fst) (ctxtAlist ctxt) ++- -- Explicitly add primitive types, as these are special-cased in the parser- ["Int", "Integer", "Float", "Char", "String", "Type",- "Ptr", "Bits8", "Bits16", "Bits32", "Bits64",- "Bits8x16", "Bits16x8", "Bits32x4", "Bits64x2"]+ "Type" : map fst Idris.ParseExpr.constants metavars :: Idris [String] metavars = do i <- get@@ -124,7 +97,7 @@ isWhitespace = (flip elem) " \t\n" lookupInHelp :: String -> Maybe CmdArg-lookupInHelp cmd = lookupInHelp' cmd help+lookupInHelp cmd = lookupInHelp' cmd allHelp where lookupInHelp' cmd ((cmds, arg, _):xs) | elem cmd cmds = Just arg | otherwise = lookupInHelp' cmd xs lookupInHelp' cmd [] = Nothing@@ -155,6 +128,8 @@ completeColourFormat = let getCmpl = completeWith (colours ++ formats) in completeWord Nothing " \t" (return . getCmpl) +-- The FIXMEs are Issue #1768 on the issue tracker.+-- https://github.com/idris-lang/Idris-dev/issues/1768 -- | Get the completion function for a particular command completeCmd :: String -> CompletionFunc Idris completeCmd cmd (prev, next) = fromMaybe completeCmdName $ fmap completeArg $ lookupInHelp cmd@@ -169,9 +144,11 @@ completeArg NoArg = noCompletion (prev, next) completeArg ConsoleWidthArg = completeConsoleWidth (prev, next) completeArg DeclArg = completeExpr [] (prev, next)+ completeArg PkgArgs = completePkg (prev, next) completeArg (ManyArgs a) = completeArg a completeArg (OptionalArg a) = completeArg a completeArg (SeqArgs a b) = completeArg a+ completeArg _ = noCompletion (prev, next) completeCmdName = return $ ("", completeWith commands cmd) -- | Complete REPL commands and defined identifiers@@ -182,14 +159,22 @@ where firstWord = fst $ break isWhitespace $ dropWhile isWhitespace $ reverse prev +completePkg :: CompletionFunc Idris+completePkg = completeWord Nothing " \t()" completeP+ where completeP p = do pkgs <- runIO installedPackages+ return $ completeWith pkgs p++-- The TODOs are Issue #1769 on the issue tracker.+-- https://github.com/idris-lang/Idris-dev/issues/1769 completeTactic :: [String] -> String -> CompletionFunc Idris completeTactic as tac (prev, next) = fromMaybe completeTacName . fmap completeArg $ lookup tac tacticArgs where completeTacName = return $ ("", completeWith tactics tac)- completeArg Nothing = noCompletion (prev, next)- completeArg (Just NameTArg) = noCompletion (prev, next) -- this is for binding new names!- completeArg (Just ExprTArg) = completeExpr as (prev, next)- completeArg (Just AltsTArg) = noCompletion (prev, next) -- TODO+ completeArg Nothing = noCompletion (prev, next)+ completeArg (Just NameTArg) = noCompletion (prev, next) -- this is for binding new names!+ completeArg (Just ExprTArg) = completeExpr as (prev, next)+ completeArg (Just StringLitTArg) = noCompletion (prev, next)+ completeArg (Just AltsTArg) = noCompletion (prev, next) -- TODO -- | Complete tactics and their arguments proverCompletion :: [String] -- ^ The names of current local assumptions
src/Idris/Core/Binary.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-| Binary instances for the core datatypes -} module Idris.Core.Binary where@@ -118,6 +118,10 @@ put (ReflectionFailed str e) = do putWord8 33 put str put e+ put (WithFnType t) = do putWord8 34+ put t+ put (CantMatch t) = do putWord8 35+ put t get = do i <- getWord8 case i of@@ -171,6 +175,8 @@ return $ ReflectionError x y 33 -> do x <- get ; y <- get return $ ReflectionFailed x y+ 34 -> fmap WithFnType get+ 35 -> fmap CantMatch get _ -> error "Corrupted binary data for Err'" ----- Generated by 'derive' @@ -397,15 +403,23 @@ return (RUType x1) _ -> error "Corrupted binary data for Raw" +instance Binary ImplicitInfo where+ put x+ = case x of+ Impl x1 -> put x1+ get+ = do x1 <- get+ return (Impl x1) instance (Binary b) => Binary (Binder b) where put x = case x of Lam x1 -> do putWord8 0 put x1- Pi x1 x2 -> do putWord8 1- put x1- put x2+ Pi x1 x2 x3 -> do putWord8 1+ put x1+ put x2+ put x3 Let x1 x2 -> do putWord8 2 put x1 put x2@@ -431,7 +445,8 @@ return (Lam x1) 1 -> do x1 <- get x2 <- get- return (Pi x1 x2)+ x3 <- get+ return (Pi x1 x2 x3) 2 -> do x1 <- get x2 <- get return (Let x1 x2)
src/Idris/Core/CaseTree.hs view
@@ -41,7 +41,7 @@ deriving instance NFData SC' !-} -data CaseType = Updatable | Shared +data CaseType = Updatable | Shared deriving (Eq, Ord, Show) type SC = SC' Term@@ -184,7 +184,7 @@ fce == txt "Force" = directUse a -- forcing a value counts as a use | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them- | (P (TCon _ _) n _, args) <- unApply fn = [] -- type constructors not used at runtime + | (P (TCon _ _) n _, args) <- unApply fn = [] -- type constructors not used at runtime | otherwise = nub $ directUse f ++ directUse a directUse (Proj x i) = nub $ directUse x directUse _ = []@@ -233,20 +233,20 @@ -- Generate a simple case tree -- Work Right to Left -simpleCase :: Bool -> Bool -> Bool ->+simpleCase :: Bool -> SC -> Bool -> Phase -> FC -> [Int] -> [Type] -> [([Name], Term, Term)] -> ErasureInfo -> TC CaseDef-simpleCase tc cover reflect phase fc inacc argtys cs erInfo- = sc' tc cover phase fc (filter (\(_, _, r) ->+simpleCase tc defcase reflect phase fc inacc argtys cs erInfo+ = sc' tc defcase phase fc (filter (\(_, _, r) -> case r of Impossible -> False _ -> True) cs) where- sc' tc cover phase fc []+ sc' tc defcase phase fc [] = return $ CaseDef [] (UnmatchedCase "No pattern clauses") []- sc' tc cover phase fc cs+ sc' tc defcase phase fc cs = let proj = phase == RunTime vnames = fstT (head cs) pats = map (\ (avs, l, r) ->@@ -258,16 +258,11 @@ ns = take numargs args (ns', ps') = order [(n, i `elem` inacc) | (i,n) <- zip [0..] ns] pats (tree, st) = runCaseBuilder erInfo- (match ns' ps' (defaultCase cover)) + (match ns' ps' defcase) ([], numargs, []) t = CaseDef ns (prune proj (depatt ns' tree)) (fstT st) in- if proj then return (stripLambdas t) + if proj then return (stripLambdas t) else return t--- FIXME: This check is not quite right in some cases, and is breaking--- perfectly valid code!--- if checkSameTypes (lstT st) tree--- then return t--- else Error (At fc (Msg "Typecase is not allowed")) Error err -> Error (At fc err) where args = map (\i -> sMN i "e") [0..] defaultCase True = STerm Erased@@ -311,23 +306,25 @@ -- FIXME: All we're actually doing here is checking that we haven't arrived -- at a specific constructor for a polymorphic argument. I *think* this -- is sufficient, but if it turns out not to be, fix it!+--+-- Issue #1718 on the issue tracker: https://github.com/idris-lang/Idris-dev/issues/1718 isType n t | (P (TCon _ _) _ _, _) <- unApply t = True isType n t | (P Ref _ _, _) <- unApply t = True isType n t = False -isConstType (I _) (AType (ATInt ITNative)) = True -isConstType (BI _) (AType (ATInt ITBig)) = True -isConstType (Fl _) (AType ATFloat) = True -isConstType (Ch _) (AType (ATInt ITChar)) = True -isConstType (Str _) StrType = True -isConstType (B8 _) (AType (ATInt _)) = True -isConstType (B16 _) (AType (ATInt _)) = True -isConstType (B32 _) (AType (ATInt _)) = True -isConstType (B64 _) (AType (ATInt _)) = True -isConstType (B8V _) (AType (ATInt _)) = True -isConstType (B16V _) (AType (ATInt _)) = True -isConstType (B32V _) (AType (ATInt _)) = True -isConstType (B64V _) (AType (ATInt _)) = True +isConstType (I _) (AType (ATInt ITNative)) = True+isConstType (BI _) (AType (ATInt ITBig)) = True+isConstType (Fl _) (AType ATFloat) = True+isConstType (Ch _) (AType (ATInt ITChar)) = True+isConstType (Str _) StrType = True+isConstType (B8 _) (AType (ATInt _)) = True+isConstType (B16 _) (AType (ATInt _)) = True+isConstType (B32 _) (AType (ATInt _)) = True+isConstType (B64 _) (AType (ATInt _)) = True+isConstType (B8V _) (AType (ATInt _)) = True+isConstType (B16V _) (AType (ATInt _)) = True+isConstType (B32V _) (AType (ATInt _)) = True+isConstType (B64V _) (AType (ATInt _)) = True isConstType _ _ = False data Pat = PCon Bool Name Int [Pat]@@ -370,13 +367,10 @@ toPat' [] (P Bound n ty) = PV n ty toPat' args (App f a) = toPat' (a : args) f- toPat' [] (Constant (AType _)) = PTyPat- toPat' [] (Constant StrType) = PTyPat- toPat' [] (Constant PtrType) = PTyPat- toPat' [] (Constant VoidType) = PTyPat- toPat' [] (Constant x) = PConst x+ toPat' [] (Constant x) | isTypeConst x = PTyPat+ | otherwise = PConst x - toPat' [] (Bind n (Pi t _) sc)+ toPat' [] (Bind n (Pi _ t _) sc) | reflect && noOccurrence n sc = PReflected (sUN "->") [toPat' [] t, toPat' [] sc] @@ -430,10 +424,10 @@ -- constructor tags between families, and no constructor/constant -- clash, because otherwise we can't reliable make the -- case distinction on evaluation- (patnames_ord, patnames_rest) + (patnames_ord, patnames_rest) = Data.List.partition (noClash . map snd) patnames -- note: sortBy . reverse is not nonsense because sortBy is stable- pats' = transpose (sortBy moreDistinct (reverse patnames_ord) + pats' = transpose (sortBy moreDistinct (reverse patnames_ord) ++ patnames_rest) in (getNOrder pats', zipWith rebuild pats' cs) where@@ -523,7 +517,7 @@ altGroups (ConGroup _ (CConst c) args : cs) = (:) <$> altConstGroup c args <*> altGroups cs - altGroup n i args + altGroup n i args = do inacc <- inaccessibleArgs n (newVars, accVars, inaccVars, nextCs) <- argsToAlt inacc args matchCs <- match (accVars ++ vs ++ inaccVars) nextCs err@@ -556,7 +550,7 @@ -- Create names for new variables arising from the given patterns. getNewVars :: [Pat] -> CaseBuilder [Name] getNewVars [] = return []- getNewVars ((PV n t) : ns) = do v <- getVar "e" + getNewVars ((PV n t) : ns) = do v <- getVar "e" nsv <- getNewVars ns -- Record the type of the variable.@@ -666,6 +660,7 @@ applyMaps ms t = t -- FIXME: Do this for SucCase too+-- Issue #1719 on the issue tracker: https://github.com/idris-lang/Idris-dev/issues/1719 prune :: Bool -- ^ Convert single branches to projections (only useful at runtime) -> SC -> SC prune proj (Case up n alts) = case alts' of@@ -689,9 +684,9 @@ -- with sc as@[ConCase cn i args sc] | proj -> let sc' = prune proj sc in- if any (isUsed sc') args + if any (isUsed sc') args then Case up n [ConCase cn i args sc']- else sc' + else sc' [SucCase cn sc] | proj@@ -795,4 +790,3 @@ = DefaultCase (mkForceSC n arg rhs) forceTm n arg t = subst n arg t-
src/Idris/Core/Constraints.hs view
@@ -6,7 +6,6 @@ import Control.Applicative import Control.Arrow-import Control.Monad.Error import Control.Monad.RWS import Control.Monad.State import Data.List@@ -56,15 +55,16 @@ = Error $ At fc UniverseError -- FIXME: Make informative -- e.g. (Msg ("Cycle: " ++ show cv ++ ", " ++ show path))+ -- Issue #1725 on the issue tracker.+ -- https://github.com/idris-lang/Idris-dev/issues/1725 -- if we reach a cycle but we're at the same universe level, it's -- fine, because they must all be equal, so stop. | inc == 0 && cv `elem` map fst path = return ()- | otherwise + | otherwise = case M.lookup cv r of Nothing -> return () Just cs -> mapM_ (next r ((cv, fc):path) inc) cs next r path inc (ULT l x, fc) = check fc r path (inc + 1) x next r path inc (ULE l x, fc) = check fc r path inc x-
src/Idris/Core/DeepSeq.hs view
@@ -1,7 +1,10 @@+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+ module Idris.Core.DeepSeq where import Idris.Core.TT import Idris.Core.CaseTree+import Idris.Core.Evaluate import Control.DeepSeq @@ -11,6 +14,7 @@ rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf NErased = () rnf (SN x1) = rnf x1 `seq` ()+ rnf (SymRef x1) = rnf x1 `seq` () instance NFData SpecialName where rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()@@ -22,11 +26,17 @@ rnf (ElimN x1) = rnf x1 `seq` () rnf (InstanceCtorN x1) = rnf x1 `seq` () +instance NFData Universe where+ rnf NullType = ()+ rnf UniqueType = ()+ rnf AllTypes = ()+ instance NFData Raw where rnf (Var x1) = rnf x1 `seq` () rnf (RBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf RType = ()+ rnf (RUType x1) = rnf x1 `seq` () rnf (RForce x1) = rnf x1 `seq` () rnf (RConstant x1) = x1 `seq` () @@ -45,9 +55,20 @@ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (UnifyScope x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+ rnf (ElaboratingArg x1 x2 x3 x4)+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () rnf (CantInferType x1) = rnf x1 `seq` ()+ rnf (CantMatch x1) = rnf x1 `seq` ()+ rnf (ReflectionError x1 x2) = x1 `seq` rnf x2 `seq` ()+ rnf (ReflectionFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (CantSolveGoal x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (UniqueError x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (UniqueKindError x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (NotEquality x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (NonFunctionType x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (CantIntroduce x1) = rnf x1 `seq` ()+ rnf (TooManyArguments x1) = rnf x1 `seq` ()+ rnf (WithFnType x1) = rnf x1 `seq` () rnf (NoSuchVariable x1) = rnf x1 `seq` () rnf (NoTypeDecl x1) = rnf x1 `seq` () rnf (NotInjective x1 x2 x3)@@ -68,9 +89,12 @@ rnf (ProviderError x1) = rnf x1 `seq` () rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` () +instance NFData ImplicitInfo where+ rnf (Impl x1) = rnf x1 `seq` ()+ instance (NFData b) => NFData (Binder b) where rnf (Lam x1) = rnf x1 `seq` ()- rnf (Pi x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (Pi x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (Hole x1) = rnf x1 `seq` ()@@ -89,17 +113,98 @@ rnf (DCon x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` () +instance NFData NativeTy where+ rnf IT8 = ()+ rnf IT16 = ()+ rnf IT32 = ()+ rnf IT64 = ()++instance NFData IntTy where+ rnf (ITFixed x1) = rnf x1 `seq` ()+ rnf ITNative = ()+ rnf ITBig = ()+ rnf ITChar = ()+ rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` ()++instance NFData ArithTy where+ rnf (ATInt x1) = rnf x1 `seq` ()+ rnf ATFloat = ()++instance NFData Const where+ rnf (I x1) = rnf x1 `seq` ()+ rnf (BI x1) = rnf x1 `seq` ()+ rnf (Fl x1) = rnf x1 `seq` ()+ rnf (Ch x1) = rnf x1 `seq` ()+ rnf (Str x1) = rnf x1 `seq` ()+ rnf (B8 x1) = rnf x1 `seq` ()+ rnf (B16 x1) = rnf x1 `seq` ()+ rnf (B32 x1) = rnf x1 `seq` ()+ rnf (B64 x1) = rnf x1 `seq` ()+ rnf (B8V x1) = rnf x1 `seq` ()+ rnf (B16V x1) = rnf x1 `seq` ()+ rnf (B32V x1) = rnf x1 `seq` ()+ rnf (B64V x1) = rnf x1 `seq` ()+ rnf (AType x1) = rnf x1 `seq` ()+ rnf StrType = ()+ rnf PtrType = ()+ rnf ManagedPtrType = ()+ rnf BufferType = ()+ rnf VoidType = ()+ rnf Forgot = ()+ instance (NFData n) => NFData (TT n) where rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (V x1) = rnf x1 `seq` () rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` ()- rnf (Constant x1) = x1 `seq` ()+ rnf (Constant x1) = rnf x1 `seq` () rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf Erased = () rnf Impossible = () rnf (TType x1) = rnf x1 `seq` () rnf (UType _) = ()++instance NFData Accessibility where+ rnf Public = ()+ rnf Frozen = ()+ rnf Hidden = ()++ +instance NFData Totality where+ rnf (Total x1) = rnf x1 `seq` ()+ rnf Productive = ()+ rnf (Partial x1) = rnf x1 `seq` ()+ rnf Unchecked = ()+ +instance NFData PReason where+ rnf (Other x1) = rnf x1 `seq` ()+ rnf Itself = ()+ rnf NotCovering = ()+ rnf NotPositive = ()+ rnf (UseUndef x1) = rnf x1 `seq` ()+ rnf ExternalIO = ()+ rnf BelieveMe = ()+ rnf (Mutual x1) = rnf x1 `seq` ()+ rnf NotProductive = ()++instance NFData MetaInformation where+ rnf EmptyMI = ()+ rnf (DataMI x1) = rnf x1 `seq` ()++instance NFData Def where+ rnf (Function x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (TyDecl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (Operator x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+ rnf (CaseOp x1 x2 x3 x4 x5 x6)+ = rnf x1 `seq`+ 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` ()+ +instance NFData CaseDefs where+ rnf (CaseDefs x1 x2 x3 x4)+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () instance (NFData t) => NFData (SC' t) where rnf (Case _ x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
src/Idris/Core/Elaborate.hs view
@@ -213,12 +213,26 @@ get_probs = do ES p _ _ <- get return $! (problems (fst p)) +-- 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 goal :: Elab' aux Type goal = do ES p _ _ <- get b <- lift $ goalAtFocus (fst p) return $! (binderTy b) +is_guess :: Elab' aux Bool+is_guess = do ES p _ _ <- get+ b <- lift $ goalAtFocus (fst p)+ case b of+ Guess _ _ -> return True+ _ -> return False+ -- Get the guess at the current hole, if there is one get_guess :: Elab' aux Type get_guess = do ES p _ _ <- get@@ -254,7 +268,7 @@ isInj ctxt (App f a) = isInj ctxt f isInj ctxt (Constant _) = True isInj ctxt (TType _) = True- isInj ctxt (Bind _ (Pi _ _) sc) = True+ isInj ctxt (Bind _ (Pi _ _ _) sc) = True isInj ctxt _ = False -- get instance argument names@@ -262,6 +276,11 @@ get_instances = do ES p _ _ <- get return $! (instances (fst p)) +-- 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 unique_hole = unique_hole' False @@ -350,8 +369,8 @@ introTy :: Raw -> Maybe Name -> Elab' aux () introTy ty n = processTactic' (IntroTy ty n) -forall :: Name -> Raw -> Elab' aux ()-forall n t = processTactic' (Forall n t)+forall :: Name -> Maybe ImplicitInfo -> Raw -> Elab' aux ()+forall n i t = processTactic' (Forall n i t) letbind :: Name -> Raw -> Raw -> Elab' aux () letbind n t v = processTactic' (LetBind n t v)@@ -393,6 +412,34 @@ movelast :: Name -> Elab' aux () movelast n = processTactic' (MoveLast n) +dotterm :: Elab' aux ()+dotterm = do ES (p, a) s m <- get+ tm <- get_term+ case holes p of+ [] -> return ()+ (h : hs) -> + do let outer = findOuter h [] tm+ let p' = p { dotted = (h, outer) : dotted p }+-- trace ("DOTTING " ++ show (h, outer) ++ "\n" ++ +-- show tm) $+ put $ ES (p', a) s m+ where+ findOuter h env (P _ n _) | h == n = env+ findOuter h env (Bind n b sc)+ = union (foB b) + (findOuter h env (instantiate (P Bound n (binderTy b)) sc))+ where foB (Guess t v) = union (findOuter h env t) (findOuter h (n:env) v)+ foB (Let t v) = union (findOuter h env t) (findOuter h env v)+ foB b = findOuter h env (binderTy b)+ findOuter h env (App f a)+ = union (findOuter h env f) (findOuter h env a)+ findOuter h env _ = []+ ++get_dotterm :: Elab' aux [(Name, [Name])]+get_dotterm = do ES (p, a) s m <- get+ return (dotted p)+ -- | Set the zipper in the proof state to point at the current sub term -- (This currently happens automatically, so this will have no effect...) zipHere :: Elab' aux ()@@ -416,6 +463,9 @@ instanceArg :: Name -> Elab' aux () instanceArg n = processTactic' (Instance n) +autoArg :: Name -> Elab' aux ()+autoArg n = processTactic' (AutoArg n)+ setinj :: Name -> Elab' aux () setinj n = processTactic' (SetInjective n) @@ -443,7 +493,9 @@ env <- get_env -- let claims = getArgs ty imps -- claims <- mkClaims (normalise ctxt env ty) imps []- claims <- mkClaims (finalise ty) imps [] (map fst env)+ claims <- mkClaims (finalise ty) + (normalise ctxt env (finalise ty))+ imps [] (map fst env) ES (p, a) s prev <- get -- reverse the claims we made so that args go left to right let n = length (filter not imps)@@ -452,11 +504,12 @@ return $! claims where mkClaims :: Type -- ^ The type of the operation being applied+ -> Type -- ^ Normalised version if we need it -> [Bool] -- ^ Whether the arguments are implicit -> [(Name, Name)] -- ^ Accumulator for produced claims -> [Name] -- ^ Hypotheses -> Elab' aux [(Name, Name)] -- ^ The names of the arguments and their holes, resp.- mkClaims (Bind n' (Pi t_in _) sc) (i : is) claims hs = + mkClaims (Bind n' (Pi _ t_in _) sc) (Bind _ _ scn) (i : is) claims hs = do let t = rebind hs t_in n <- getNameFrom (mkMN n') -- when (null claims) (start_unify n)@@ -464,9 +517,11 @@ -- trace ("CLAIMING " ++ show (n, t) ++ " with " ++ show (fn, hs)) $ claim n (forget t) when i (movelast n)- mkClaims sc' is ((n', n) : claims) hs- mkClaims t [] claims _ = return $! (reverse claims)- mkClaims _ _ _ _+ mkClaims sc' scn is ((n', n) : claims) hs+ -- if we run out of arguments, we need the normalised version...+ mkClaims t tn@(Bind _ _ sc) (i : is) cs hs = mkClaims tn tn (i : is) cs hs+ mkClaims t _ [] claims _ = return $! (reverse claims)+ mkClaims _ _ _ _ _ | Var n <- fn = do ctxt <- get_context case lookupTy n ctxt of@@ -564,7 +619,7 @@ priOrder _ Nothing = GT priOrder (Just (x, _)) (Just (y, _)) = compare x y - doClaims (Bind n' (Pi t _) sc) (i : is) claims =+ doClaims (Bind n' (Pi _ t _) sc) (i : is) claims = do n <- unique_hole (mkMN n') when (null claims) (start_unify n) let sc' = instantiate (P Bound n t) sc@@ -599,13 +654,13 @@ checkPiGoal n = do g <- goal case g of- Bind _ (Pi _ _) _ -> return ()+ Bind _ (Pi _ _ _) _ -> return () _ -> do a <- getNameFrom (sMN 0 "pargTy") b <- getNameFrom (sMN 0 "pretTy") f <- getNameFrom (sMN 0 "pf") claim a RType claim b RType- claim f (RBind n (Pi (Var a) RType) (Var b))+ claim f (RBind n (Pi Nothing (Var a) RType) (Var b)) movelast a movelast b fill (Var f)@@ -620,7 +675,7 @@ s <- getNameFrom (sMN 0 "s") claim a RType claim b RType- claim f (RBind (sMN 0 "aX") (Pi (Var a) RType) (Var b))+ claim f (RBind (sMN 0 "aX") (Pi Nothing (Var a) RType) (Var b)) tm <- get_term start_unify s claim s (Var a)@@ -643,11 +698,11 @@ -- Abstract over an argument of unknown type, giving a name for the hole -- which we'll fill with the argument type too.-arg :: Name -> Name -> Elab' aux ()-arg n tyhole = do ty <- unique_hole tyhole- claim ty RType- movelast ty- forall n (Var ty)+arg :: Name -> Maybe ImplicitInfo -> Name -> Elab' aux ()+arg n i tyhole = do ty <- unique_hole tyhole+ claim ty RType+ movelast ty+ forall n i (Var ty) -- try a tactic, if it adds any unification problem, return an error no_errors :: Elab' aux () -> Maybe Err -> Elab' aux ()@@ -665,7 +720,7 @@ ps' <- get_probs if (length ps' > length ps) then case reverse ps' of- ((x, y, env, inerr, while, _) : _) ->+ ((x, y, _, env, inerr, while, _) : _) -> let env' = map (\(x, b) -> (x, binderTy b)) env in lift $ tfail $ case err of@@ -712,6 +767,7 @@ = -- traceWhen r (show err) $ r || proofSearch recoverableErr (CantSolveGoal _ _) = False+ recoverableErr (CantResolveAlts _) = False recoverableErr (ProofSearchFail (Msg _)) = True recoverableErr (ProofSearchFail _) = False recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e@@ -722,9 +778,10 @@ tryWhen True a b = try a b tryWhen False a b = a ---- Try a selection of tactics. Exactly one must work, all others must fail+-- Bool says whether it's okay to create new unification problems. If set+-- to False, then the whole tactic fails if there are any new problems tryAll :: [(Elab' aux a, Name)] -> Elab' aux a+tryAll [(x, _)] = x tryAll xs = tryAll' [] 999999 (cantResolve, 0) xs where cantResolve :: Elab' aux a@@ -743,10 +800,10 @@ ps <- get_probs case prunStateT pmax True ps x s of OK ((v, newps, probs), s') -> - do let cs' = if (newps < pmax)- then [do put s'; return $! v]- else (do put s'; return $! v) : cs- tryAll' cs' newps f xs+ do let cs' = if (newps < pmax)+ then [do put s'; return $! v]+ else (do put s'; return $! v) : cs+ tryAll' cs' newps f xs Error err -> do put s -- if (score err) < 100 tryAll' cs pmax (better err f) xs@@ -762,9 +819,9 @@ -> Bool -> [a] -> Control.Monad.State.Strict.StateT- (ElabState t) (TC' Err) t1+ (ElabState t) TC t1 -> ElabState t- -> TC' Err ((t1, Int, Idris.Core.Unify.Fails), ElabState t)+ -> TC ((t1, Int, Idris.Core.Unify.Fails), ElabState t) prunStateT pmax zok ps x s = case runStateT x s of OK (v, s'@(ES (p, _) _ _)) ->@@ -772,12 +829,12 @@ newpmax = if newps < 0 then 0 else newps in if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0)) then case reverse (problems p) of- ((_,_,_,e,_,_):_) -> Error e+ ((_,_,_,_,e,_,_):_) -> Error e else OK ((v, newpmax, problems p), s') Error e -> Error e qshow :: Fails -> String-qshow fs = show (map (\ (x, y, _, _, _, _) -> (x, y)) fs)+qshow fs = show (map (\ (x, y, _, _, _, _, _) -> (x, y)) fs) dumpprobs [] = "" dumpprobs ((_,_,_,e):es) = show e ++ "\n" ++ dumpprobs es
src/Idris/Core/Evaluate.hs view
@@ -8,10 +8,10 @@ Context, initContext, ctxtAlist, uconstraints, next_tvar, addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl, addDatatype, addCasedef, simplifyCasedef, addOperator,- lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact, + lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact, lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal, mapDefCtxt,- lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,+ lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, isTConName, isConName, isFnName, Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions, isUniverse) where @@ -25,7 +25,8 @@ import Idris.Core.CaseTree data EvalState = ES { limited :: [(Name, Int)],- nexthole :: Int }+ nexthole :: Int,+ blocking :: Bool } deriving Show type Eval a = State EvalState a@@ -37,7 +38,7 @@ | RunTT deriving (Show, Eq) -initEval = ES [] 0+initEval = ES [] 0 False -- VALUES (as HOAS) --------------------------------------------------------- -- | A HOAS representation of values@@ -91,7 +92,7 @@ -- Return a specialised name, and an updated list of reductions available, -- so that the caller can tell how much specialisation was achieved.-specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> +specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> (TT Name, [(Name, Int)]) specialise ctxt env limits t = let (tm, st) =@@ -161,11 +162,12 @@ -- usable _ _ ns@((MN 0 "STOP", _) : _) = return (False, ns) usable False n [] = return (True, []) usable True n ns- = do ES ls num <- get- case lookup n ls of- Just 0 -> return (False, ns)- Just i -> return (True, ns)- _ -> return (False, ns)+ = do ES ls num b <- get+ if b then return (False, ns)+ else case lookup n ls of+ Just 0 -> return (False, ns)+ Just i -> return (True, ns)+ _ -> return (False, ns) usable False n ns = case lookup n ns of Just 0 -> return (False, ns)@@ -174,13 +176,17 @@ fnCount :: Int -> Name -> Eval ()-fnCount inc n - = do ES ls num <- get+fnCount inc n+ = do ES ls num b <- get case lookup n ls of Just i -> do put $ ES ((n, (i - inc)) :- filter (\ (n', _) -> n/=n') ls) num+ filter (\ (n', _) -> n/=n') ls) num b _ -> return () +setBlock :: Bool -> Eval ()+setBlock b = do ES ls num _ <- get+ put (ES ls num b)+ deduct = fnCount 1 reinstate = fnCount (-1) @@ -249,7 +255,7 @@ ev ntimes stk top env (V i) | i < length env && i >= 0 = return $ snd (env !! i) | otherwise = return $ VV i- ev ntimes stk top env (Bind n (Let t v) sc) + ev ntimes stk top env (Bind n (Let t v) sc) | not runtime || occurrences n sc < 2 = do v' <- ev ntimes stk top env v --(finalise v) sc' <- ev ntimes stk top ((n, v') : env) sc@@ -277,17 +283,19 @@ where vbind env t = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t -- block reduction immediately under codata (and not forced)- ev ntimes stk top env + ev ntimes stk top env (App (App (App d@(P _ (UN dly) _) l@(P _ (UN lco) _)) t) arg) | dly == txt "Delay" && lco == txt "LazyCodata" && not simpl = do let (f, _) = unApply arg let ntimes' = case f of P _ fn _ -> (fn, 0) : ntimes _ -> ntimes+ when spec $ setBlock True d' <- ev ntimes' stk False env d l' <- ev ntimes' stk False env l t' <- ev ntimes' stk False env t arg' <- ev ntimes' stk False env arg+ when spec $ setBlock False evApply ntimes' stk top env [l',t',arg'] d' -- Treat "assert_total" specially, as long as it's defined! ev ntimes stk top env (App (App (P _ n@(UN at) _) _) arg)@@ -303,7 +311,7 @@ t' <- ev ntimes stk top env t -- tfull' <- reapply ntimes stk top env t' [] return (doProj t' (getValArgs t'))- where doProj t' (VP (DCon _ _ _) _ _, args) + where doProj t' (VP (DCon _ _ _) _ _, args) | i >= 0 && i < length args = args!!i doProj t' _ = VProj t' i @@ -330,7 +338,7 @@ _ -> case args of (a : as) -> return $ unload env f (a : as) [] -> return f- reapply ntimes stk top env (VApp f a) args + reapply ntimes stk top env (VApp f a) args = reapply ntimes stk top env f (a : args) reapply ntimes stk top env v args = return v @@ -348,7 +356,7 @@ do let val = lookupDefAcc n (spec || atRepl) ctxt case val of [(CaseOp ci _ _ _ _ cd, acc)]- | acc /= Frozen || sUN "assert_total" `elem` stk -> + | acc /= Frozen || sUN "assert_total" `elem` stk -> -- unoptimised version let (ns, tree) = getCases cd in if blockSimplify ci n stk@@ -394,7 +402,7 @@ t <- evTree ntimes stk top env (zip ns args') tree when spec $ case t of Nothing -> reinstate n -- Blocked, count n again- Just _ -> return () + Just _ -> return () -- (zipWith (\n , t) -> (n, t)) ns args') tree return (t, rest) | otherwise = return (Nothing, args)@@ -408,7 +416,7 @@ (amap ++ env) etm return $ Just etm' evTree ntimes stk top env amap (ProjCase t alts)- = do t' <- ev ntimes stk top env t + = do t' <- ev ntimes stk top env t doCase ntimes stk top env amap t' alts evTree ntimes stk top env amap (Case _ n alts) = case lookup n amap of@@ -451,7 +459,7 @@ | Just v <- findDefault alts = return $ Just (amap, v) chooseAlt env _ (VP _ n _, args) alts amap | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)- chooseAlt env _ (VBind _ _ (Pi s k) t, []) alts amap+ chooseAlt env _ (VBind _ _ (Pi i s k) t, []) alts amap | Just (ns, sc) <- findFn (sUN "->") alts = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern return $ Just (updateAmap (zip ns [s, t']) amap, sc)@@ -563,9 +571,9 @@ convEq' ctxt hs x y = evalStateT (convEq ctxt hs x y) (0, []) -convEq :: Context -> [Name] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool+convEq :: Context -> [Name] -> TT Name -> TT Name -> StateT UCs TC Bool convEq ctxt holes topx topy = ceq [] topx topy where- ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool+ ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs TC Bool ceq ps (P xt x _) (P yt y _) | x `elem` holes || y `elem` holes = return True | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True@@ -583,10 +591,10 @@ ceq ps x (Bind n (PVTy t) sc) = ceq ps x sc ceq ps (V x) (V y) = return (x == y)- ceq ps (V x) (P _ y _) + ceq ps (V x) (P _ y _) | x >= 0 && length ps > x = return (fst (ps!!x) == y) | otherwise = return False- ceq ps (P _ x _) (V y) + ceq ps (P _ x _) (V y) | y >= 0 && length ps > y = return (x == snd (ps!!y)) | otherwise = return False ceq ps (Bind n xb xs) (Bind n' yb ys)@@ -594,7 +602,7 @@ where ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')- ceqB ps (Pi v t) (Pi v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')+ ceqB ps (Pi i v t) (Pi i' v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') ceqB ps b b' = ceq ps (binderTy b) (binderTy b') ceq ps (App fx ax) (App fy ay) = liftM2 (&&) (ceq ps fx fy) (ceq ps ax ay) ceq ps (Constant x) (Constant y) = return (x == y)@@ -684,6 +692,15 @@ {-! deriving instance Binary CaseDefs !-}+{-!+deriving instance NFData Def+!-}+{-!+deriving instance NFData CaseInfo+!-}+{-!+deriving instance NFData CaseDefs+!-} instance Show Def where show (Function ty tm) = "Function: " ++ show (ty, tm)@@ -709,6 +726,9 @@ data Accessibility = Public | Frozen | Hidden deriving (Show, Eq)+{-!+deriving instance NFData Accessibility+!-} -- | The result of totality checking data Totality = Total [Int] -- ^ well-founded arguments@@ -716,11 +736,17 @@ | Partial PReason | Unchecked deriving Eq+{-!+deriving instance NFData Totality+!-} -- | Reasons why a function may not be total data PReason = Other [Name] | Itself | NotCovering | NotPositive | UseUndef Name | ExternalIO | BelieveMe | Mutual [Name] | NotProductive deriving (Show, Eq)+{-!+deriving instance NFData PReason+!-} instance Show Totality where show (Total args)= "Total" -- ++ show args ++ " decreasing arguments"@@ -825,8 +851,12 @@ (TyDecl (DCon tag (arity ty') unique) ty, Public, Unchecked, EmptyMI) ctxt) -- FIXME: Too many arguments! Refactor all these Bools.+--+-- Issue #1724 on the issue tracker.+-- https://github.com/idris-lang/Idris-dev/issues/1724 addCasedef :: Name -> ErasureInfo -> CaseInfo ->- Bool -> Bool -> Bool -> Bool ->+ Bool -> SC -> -- default case+ Bool -> Bool -> [Type] -> -- argument types [Int] -> -- inaccessible arguments [Either Term (Term, Term)] ->@@ -872,7 +902,7 @@ [(CaseOp ci ty atys ps_in ps cd, acc, tot, metainf)] -> let ps_in' = map simpl ps_in pdef = map debind ps_in' in- case simpleCase False True False CompileTime emptyFC [] atys pdef ei of+ case simpleCase False (STerm Erased) False CompileTime emptyFC [] atys pdef ei of OK (CaseDef args sc _) -> addDef n (CaseOp ci ty atys ps_in' ps (cd { cases_totcheck = (args, sc) }),@@ -959,9 +989,18 @@ 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+ lookupP :: Name -> Context -> [Term] lookupP n ctxt- = do def <- lookupCtxt n (definitions 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)
src/Idris/Core/Execute.hs view
@@ -22,7 +22,7 @@ import Control.Exception import Control.Monad.Trans import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Error+import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad hiding (forM) import Data.Maybe import Data.Bits@@ -88,7 +88,7 @@ b' <- fixBinder b Bind n' b' <$> toTT body' where fixBinder (Lam t) = Lam <$> toTT t- fixBinder (Pi t k) = Pi <$> toTT t <*> toTT k+ fixBinder (Pi i t k) = Pi i <$> toTT t <*> toTT k fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2 fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2 fixBinder (Hole t) = Hole <$> toTT t@@ -126,10 +126,10 @@ initState = do ist <- getIState return $ ExecState (idris_dynamic_libs ist) [] -type Exec = ErrorT Err (StateT ExecState IO)+type Exec = ExceptT Err (StateT ExecState IO) runExec :: Exec a -> ExecState -> IO (Either Err a)-runExec ex st = fst <$> runStateT (runErrorT ex) st+runExec ex st = fst <$> runStateT (runExceptT ex) st getExecState :: Exec ExecState getExecState = lift get@@ -263,6 +263,13 @@ "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+ = 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@@ -525,7 +532,6 @@ call' (Fun _ h) args FPtr = EPtr <$> (execIO $ callFFI h (retPtr retVoid) (prepArgs args)) call' (Fun _ h) args FUnit = do _ <- execIO $ callFFI h retVoid (prepArgs args) return $ EP Ref unitCon EErased--- call' (Fun _ h) args other = fail ("Unsupported foreign return type " ++ show other) prepArgs = map prepArg@@ -536,6 +542,8 @@ prepArg (EConstant (B64 i)) = argCLong (fromIntegral i) prepArg (EConstant (Fl f)) = argCDouble (realToFrac f) prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars+ -- Issue #1720 on the issue tracker.+ -- https://github.com/idris-lang/Idris-dev/issues/1720 prepArg (EConstant (Str s)) = argString s prepArg (EPtr p) = argPtr p prepArg other = trace ("Could not use " ++ take 100 (show other) ++ " as FFI arg.") undefined
src/Idris/Core/ProofState.hs view
@@ -31,16 +31,20 @@ 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 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 context :: Context, plog :: String, unifylog :: Bool, done :: Bool,+ recents :: [Name], while_elaborating :: [FailContext] } @@ -65,7 +69,7 @@ | CheckIn Raw | Intro (Maybe Name) | IntroTy Raw (Maybe Name)- | Forall Name Raw+ | Forall Name (Maybe ImplicitInfo) Raw | LetBind Name Raw Raw | ExpandLet Name Term | Rewrite Raw@@ -78,6 +82,7 @@ | Defer [Name] Name | DeferType Name Raw [Name] | Instance Name+ | AutoArg Name | SetInjective Name | MoveLast Name | MatchProblems Bool@@ -90,10 +95,12 @@ -- Some utilites on proof and tactic states instance Show ProofState where- show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)- = show nm ++ ": no more goals"- show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _)- = let OK g = goal (Just h) tm+ show ps | [] <- holes ps+ = show (thname ps) ++ ": no more goals"+ show ps | (h : hs) <- holes ps+ = let tm = pterm ps+ nm = thname ps+ OK g = goal (Just h) tm wkenv = premises g in "Other goals: " ++ show hs ++ "\n" ++ showPs wkenv (reverse wkenv) ++ "\n" ++@@ -115,10 +122,12 @@ showG ps b = showEnv ps (binderTy b) instance Pretty ProofState OutputAnnotation where- pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =- pretty nm <+> colon <+> text " no more goals."- pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _) =- let OK g = goal (Just h) tm in+ pretty ps | [] <- holes ps =+ pretty (thname ps) <+> colon <+> text " no more goals."+ pretty ps | (h : hs) <- holes ps =+ let tm = pterm ps+ OK g = goal (Just h) tm + nm = thname ps in let wkEnv = premises g in text "Other goals" <+> colon <+> pretty hs <+> prettyPs wkEnv (reverse wkEnv) <+>@@ -141,7 +150,7 @@ holeName i = sMN i "hole" qshow :: Fails -> String-qshow fs = show (map (\ (x, y, _, _, _, t) -> (t, x, y)) fs)+qshow fs = show (map (\ (x, y, hs, _, _, _, t) -> (t, x, y, hs)) fs) match_unify' :: Context -> Env -> TT Name -> TT Name -> StateT TState TC [(Name, TT Name)]@@ -151,10 +160,10 @@ let dont = dontunify ps let inj = injective ps traceWhen (unifylog ps)- ("Matching " ++ show (topx, topy) ++ + ("Matching " ++ show (topx, topy) ++ " in " ++ show env ++ "\nHoles: " ++ show (holes ps)- ++ "\n" + ++ "\n" ++ "\n" ++ show (getProofTerm (pterm ps)) ++ "\n\n" ) $ case match_unify ctxt env topx topy inj (holes ps) while of@@ -165,12 +174,13 @@ return u Error e -> traceWhen (unifylog ps) ("No match " ++ show e) $- do put (ps { problems = (topx, topy, env, e, while, Match) :+ do put (ps { problems = (topx, topy, True, + env, e, while, Match) : problems ps }) return [] -- traceWhen (unifylog ps) -- ("Matched " ++ show (topx, topy) ++ " without " ++ show dont ++--- "\nSolved: " ++ show u +-- "\nSolved: " ++ show u -- ++ "\nCurrent problems:\n" ++ qshow (problems ps) -- -- ++ show (pterm ps) -- ++ "\n----------") $@@ -183,7 +193,7 @@ | Just t' <- lookup n ns = do ps <- get let probs = problems ps- put (ps { problems = probs ++ [(t,t',env,Msg "New problem",+ put (ps { problems = probs ++ [(t,t',True,env,Msg "New problem", [], Unify)] }) merge acc ns | otherwise = merge ((n, t): acc) ns@@ -203,10 +213,10 @@ "\nHoles: " ++ show (holes ps) ++ "\nInjective: " ++ show (injective ps) ++ "\n") $- lift $ unify ctxt env topx topy inj (holes ps) + lift $ unify ctxt env topx topy inj (holes ps) (map fst (notunified ps)) while let notu = filter (\ (n, t) -> case t of- P _ _ _ -> False+-- P _ _ _ -> False _ -> n `elem` dont) u traceWhen (unifylog ps) ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++@@ -222,12 +232,8 @@ -- problem for each. uns <- mergeSolutions env (u' ++ ns) ps <- get- let (ns', probs') = updateProblems (context ps) uns- (fails ++ problems ps)- (injective ps)- (holes ps)- (map fst (notunified ps))- let (notu', probs_notu) = mergeNotunified env (notu ++ notunified ps)+ let (ns', probs') = updateProblems ps uns (fails ++ problems ps)+ let (notu', probs_notu) = mergeNotunified env (holes ps) (notu ++ notunified ps) traceWhen (unifylog ps) ("Now solved: " ++ show ns' ++ "\nNow problems: " ++ qshow (probs' ++ probs_notu)) $@@ -283,10 +289,10 @@ 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, []) []+ (P Bound h ty'))) ty [] (h, []) [] [] Nothing [] []- [] []- Nothing ctxt "" False False []+ [] [] []+ Nothing ctxt "" False False [] [] type TState = ProofState -- [TacticAction]) type RunTactic = RunTactic' TState@@ -381,6 +387,16 @@ instances = x:is }) return (Bind x (Hole t) sc) +autoArg :: Name -> RunTactic+autoArg n ctxt env (Bind x (Hole t) sc)+ = do action (\ps -> case lookup x (autos ps) of+ Nothing ->+ let hs = holes ps in+ ps { holes = (hs \\ [x]) ++ [x],+ autos = (x, refsIn t) : autos ps }+ Just _ -> ps)+ return (Bind x (Hole t) sc)+ setinj :: Name -> RunTactic setinj n ctxt env (Bind x b sc) = do action (\ps -> let is = injective ps in@@ -396,7 +412,7 @@ (mkApp (P Ref n ty) (map getP (reverse env')))) where mkTy [] t = t- mkTy ((n,b) : bs) t = Bind n (Pi (binderTy b) (TType (UVar 0))) (mkTy bs t)+ mkTy ((n,b) : bs) t = Bind n (Pi Nothing (binderTy b) (TType (UVar 0))) (mkTy bs t) getP (n, b) = P Bound n (binderTy b) @@ -416,7 +432,7 @@ Nothing -> error ("deferType can't find " ++ show n) regret :: RunTactic-regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc = +regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc = do action (\ps -> let hs = holes ps in ps { holes = hs \\ [x] }) return sc@@ -485,18 +501,27 @@ solve ctxt env (Bind x (Guess ty val) sc) = do ps <- get let (uh, uns) = unified ps- case lookup x (notunified ps) of- Just tm -> -- trace ("NEED MATCH: " ++ show (x, tm, val) ++ "\nIN " ++ show (pterm ps)) $- match_unify' ctxt env tm val- _ -> return []+ 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+ return [x]+ _ -> return [] action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping hole " ++ show x) $ holes ps \\ [x], solved = Just (x, val), notunified = updateNotunified [(x,val)] (notunified ps),- instances = instances ps \\ [x] })- let tm' = subst x val sc in + recents = x : recents ps,+ instances = instances ps \\ [x],+ dotted = dropUnified dropdots (dotted ps) })+ let tm' = subst x val sc in return tm'+ where dropUnified ddots [] = []+ dropUnified ddots ((x, es) : ds)+ | x `elem` ddots || any (\e -> e `elem` ddots) es+ = dropUnified ddots ds+ | otherwise = (x, es) : dropUnified ddots ds solve _ _ h@(Bind x t sc) = do ps <- get case findType x sc of@@ -504,7 +529,7 @@ _ -> lift $ tfail (IncompleteTerm h) where findType x (Bind n (Let t v) sc) = findType x v `mplus` findType x sc- findType x (Bind n t sc) + findType x (Bind n t sc) | P _ x' _ <- binderTy t, x == x' = Just n | otherwise = findType x sc findType x _ = Nothing@@ -515,17 +540,17 @@ Just name -> name Nothing -> x let t' = case t of- x@(Bind y (Pi s _) _) -> x+ x@(Bind y (Pi _ s _) _) -> x _ -> hnf ctxt env t (tyv, tyt) <- lift $ check ctxt env ty -- ns <- lift $ unify ctxt env tyv t' case t' of- Bind y (Pi s _) t -> let t' = subst y (P Bound n s) t in- do ns <- unify' ctxt env s tyv- ps <- get- let (uh, uns) = unified ps--- put (ps { unified = (uh, uns ++ ns) })- return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t'))+ Bind y (Pi _ s _) t -> let t' = subst y (P Bound n s) t in+ do ns <- unify' ctxt env s tyv+ ps <- get+ let (uh, uns) = unified ps+-- put (ps { unified = (uh, uns ++ ns) })+ return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t')) _ -> lift $ tfail $ CantIntroduce t' introTy ty n ctxt env _ = fail "Can't introduce here." @@ -535,31 +560,32 @@ Just name -> name Nothing -> x let t' = case t of- x@(Bind y (Pi s _) _) -> x+ x@(Bind y (Pi _ s _) _) -> x _ -> hnf ctxt env t case t' of- Bind y (Pi s _) t -> -- trace ("in type " ++ show t') $+ Bind y (Pi _ s _) t -> -- trace ("in type " ++ show t') $ let t' = subst y (P Bound n s) t in return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t')) _ -> lift $ tfail $ CantIntroduce t' intro n ctxt env _ = fail "Can't introduce here." -forall :: Name -> Raw -> RunTactic-forall n ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =+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))- return $ Bind n (Pi tyv (TType (UVar 0))) (Bind x (Hole t) (P Bound x t))-forall n ty ctxt env _ = fail "Can't pi bind here"+ 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" patvar :: Name -> RunTactic-patvar n ctxt env (Bind x (Hole t) sc) = +patvar n ctxt env (Bind x (Hole t) sc) = do action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping pattern hole " ++ show x) $ holes ps \\ [x], solved = Just (x, P Bound n t), notunified = updateNotunified [(x,P Bound n t)] (notunified ps),- injective = addInj n x (injective ps) })+ injective = addInj n x (injective ps)+ }) return $ Bind n (PVar t) (subst x (P Bound n t) sc) where addInj n x ps | x `elem` ps = n : ps | otherwise = ps@@ -590,7 +616,7 @@ [lt, l, r, p, tmv, xp])) (scv, sct) <- lift $ check ctxt env sc return scv- _ -> lift $ tfail (NotEquality tmv tmt') + _ -> lift $ tfail (NotEquality tmv tmt') where rname = sMN 0 "replaced" rewrite _ _ _ _ = fail "Can't rewrite here" @@ -647,7 +673,8 @@ consargs' <- query (\ps -> map (flip (uniqueNameCtxt (context ps)) (holes ps ++ allTTNames (getProofTerm (pterm ps))) *** uniqueBindersCtxt (context ps) (holes ps ++ allTTNames (getProofTerm (pterm ps)))) consargs) let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (tacn tnm)) (TType (UVal 0))) (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv])))- action (\ps -> ps {holes = holes ps \\ [x]})+ action (\ps -> ps {holes = holes ps \\ [x],+ recents = x : recents ps }) mapM_ addConsHole (reverse consargs') let res' = forget $ res (scv, sct) <- lift $ check ctxt env res'@@ -739,7 +766,8 @@ let (_, ns) = unified ps let unify = dropGiven (dontunify ps) ns (holes ps) action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping holes " ++ show (map fst unify)) $- holes ps \\ map fst unify })+ holes ps \\ map fst unify,+ recents = recents ps ++ map fst unify }) action (\ps -> ps { pterm = updateSolved unify (pterm ps) }) return (updateSolvedTerm unify tm) @@ -764,12 +792,13 @@ updateEnv [] e = e updateEnv ns [] = []-updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env+updateEnv ns ((n, b) : env) + = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env 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) +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@@ -777,16 +806,16 @@ solveInProblems x val [] = [] solveInProblems x val ((l, r, env, err) : ps)- = ((psubst x val l, psubst x val r, + = ((psubst x val l, psubst x val r, updateEnv [(x, val)] env, err) : solveInProblems x val ps) -mergeNotunified :: Env -> [(Name, Term)] -> ([(Name, Term)], Fails)-mergeNotunified env ns = mnu ns [] [] where+mergeNotunified :: Env -> [Name] -> [(Name, Term)] -> ([(Name, Term)], Fails)+mergeNotunified env holes ns = mnu ns [] [] where mnu [] ns_acc ps_acc = (reverse ns_acc, reverse ps_acc) mnu ((n, t):ns) ns_acc ps_acc | Just t' <- lookup n ns, t /= t'- = mnu ns ((n,t') : ns_acc) - ((t,t',env,CantUnify True t t' (Msg "") [] 0, [],Match) : ps_acc)+ = mnu ns ((n,t') : ns_acc)+ ((t,t',True, env,CantUnify True t t' (Msg "") [] 0, [],Match) : ps_acc) | otherwise = mnu ns ((n,t) : ns_acc) ps_acc updateNotunified [] nu = nu@@ -795,40 +824,53 @@ up ((n, t) : nus) = let t' = updateSolvedTerm ns t in ((n, t') : up nus) --- FIXME: Why not just pass the whole proof state?-updateProblems :: Context -> [(Name, TT Name)] -> Fails -> [Name] -> [Name] -> [Name]- -> ([(Name, TT Name)], Fails)+updateProblems :: ProofState -> [(Name, TT Name)] -> Fails + -> ([(Name, TT Name)], Fails) -- updateProblems ctxt [] ps inj holes = ([], ps)-updateProblems ctxt ns ps inj holes usupp = up ns ps where+updateProblems ps updates probs = up updates probs where+ hs = holes ps+ inj = injective ps+ ctxt = context ps+ usupp = map fst (notunified ps)+ up ns [] = (ns, [])- up ns ((x, y, env, err, while, um) : ps) =- let x' = updateSolvedTerm ns x- y' = updateSolvedTerm ns y+ up ns (prob@(x, y, ready, env, err, while, um) : ps) =+ let (x', newx) = updateSolvedTerm' ns x+ (y', newy) = updateSolvedTerm' ns y err' = updateError ns err env' = updateEnv ns env in--- trace ("Updating " ++ show (x',y')) $ - case unify ctxt env' x' y' inj holes usupp while of- OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $+ 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- e -> -- trace ("Failed " ++ show e) $- let (ns', ps') = up ns ps in- (ns', (x',y',env',err', while, um) : 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')+ else -- trace ("SKIPPING " ++ show (x,y,ready)) $+ let (ns', ps') = up ns ps in+ (ns', (x',y', False, env',err', while, um) : ps') -- attempt to solve remaining problems with match_unify--- matchProblems :: Bool -> Elab' aux ()-matchProblems all ns ctxt ps inj holes = up ns ps where+matchProblems :: Bool -> ProofState -> [(Name, TT Name)] -> Fails + -> ([(Name, TT Name)], Fails)+matchProblems all ps updates probs = up updates probs where+ hs = holes ps+ inj = injective ps+ ctxt = context ps+ up ns [] = (ns, [])- up ns ((x, y, env, err, while, um) : ps)+ up ns ((x, y, ready, env, err, while, um) : ps) | all || um == Match = let x' = updateSolvedTerm ns x y' = updateSolvedTerm ns y err' = updateError ns err env' = updateEnv ns env in- case match_unify ctxt env' x' y' inj holes while of+ case match_unify ctxt env' x' y' 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- (ns', (x', y', env', err', while, um) : ps')+ (ns', (x', y', True, env', err', while, um) : ps') up ns (p : ps) = let (ns', ps') = up ns ps in (ns', p : ps') @@ -847,55 +889,47 @@ = let (h, ns_in) = unified ps ns = dropGiven (dontunify ps) ns_in (holes ps) ns' = map (\ (n, t) -> (n, updateSolvedTerm ns t)) ns- (ns'', probs') = updateProblems (context ps) ns' (problems ps)- (injective ps) (holes ps)- (map fst (notunified ps))+ (ns'', probs') = updateProblems ps ns' (problems ps) tm' = updateSolved ns'' (pterm ps) in- traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $- return (ps { pterm = tm',- unified = (h, []),- problems = probs',- notunified = updateNotunified ns'' (notunified ps),- holes = holes ps \\ map fst ns'' }, "")+ traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $+ return (ps { pterm = tm',+ unified = (h, []),+ problems = probs',+ notunified = updateNotunified ns'' (notunified ps),+ recents = recents ps ++ map fst ns'',+ holes = holes ps \\ map fst ns'' }, "") processTactic UnifyAll ps = let tm' = updateSolved (notunified ps) (pterm ps) in return (ps { pterm = tm', notunified = [],+ recents = recents ps ++ map fst (notunified ps), holes = holes ps \\ map fst (notunified ps) }, "") processTactic (Reorder n) ps = do ps' <- execStateT (tactic (Just n) reorder_claims) ps return (ps' { previous = Just ps, plog = "" }, plog ps') processTactic (ComputeLet n) ps = return (ps { pterm = mkProofTerm $- computeLet (context ps) n + computeLet (context ps) n (getProofTerm (pterm ps)) }, "") processTactic UnifyProblems ps- = let (ns', probs') = updateProblems (context ps) []- (problems ps)- (injective ps)- (holes ps)- (map fst (notunified ps))- pterm' = updateSolved ns' (pterm ps) in- traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns')) $- return (ps { pterm = pterm', solved = Nothing, problems = probs',- previous = Just ps, plog = "",- notunified = updateNotunified ns' (notunified ps),- holes = holes ps \\ (map fst ns') }, plog ps)+ = do let (ns', probs') = updateProblems ps [] (problems ps)+ pterm' = updateSolved ns' (pterm ps)+ traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns')) $+ return (ps { pterm = pterm', solved = Nothing, problems = probs',+ previous = Just ps, plog = "",+ notunified = updateNotunified ns' (notunified ps),+ recents = recents ps ++ map fst ns',+ holes = holes ps \\ (map fst ns') }, plog ps) processTactic (MatchProblems all) ps- = let (ns', probs') = matchProblems all [] (context ps)- (problems ps)- (injective ps)- (holes ps)- (ns'', probs'') = matchProblems all ns' (context ps)- probs'- (injective ps)- (holes ps)- pterm' = updateSolved ns'' (pterm ps) in- traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $- return (ps { pterm = pterm', solved = Nothing, problems = probs'',- previous = Just ps, plog = "",- notunified = updateNotunified ns'' (notunified ps),- holes = holes ps \\ (map fst ns'') }, plog ps)+ = 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'')) $+ return (ps { pterm = pterm', solved = Nothing, problems = probs'',+ previous = Just ps, plog = "",+ notunified = updateNotunified ns'' (notunified ps),+ recents = recents ps ++ map fst ns'',+ holes = holes ps \\ (map fst ns'') }, plog ps) processTactic t ps = case holes ps of [] -> fail "Nothing to fill in."@@ -904,11 +938,7 @@ = case solved ps' of Just s -> traceWhen (unifylog ps') ("SOLVED " ++ show s) $- updateProblems (context ps')- [s] (problems ps')- (injective ps')- (holes ps')- (map fst (notunified ps))+ updateProblems ps [s] (problems ps') _ -> ([], problems ps') -- rechecking problems may find more solutions, so -- apply them here@@ -919,6 +949,7 @@ problems = probs', notunified = updateNotunified ns' (notunified ps'), previous = Just ps, plog = "",+ recents = recents ps' ++ map fst ns', holes = holes ps' \\ (map fst ns')}, plog ps') process :: Tactic -> Name -> StateT TState TC ()@@ -942,7 +973,7 @@ mktac HNF_Compute = hnf_compute mktac (Intro n) = intro n mktac (IntroTy ty n) = introTy ty n- mktac (Forall n t) = forall n t+ mktac (Forall n i t) = forall n i t mktac (LetBind n t v) = letbind n t v mktac (ExpandLet n b) = expandLet n b mktac (Rewrite t) = rewrite t@@ -957,5 +988,6 @@ mktac (Defer ns n) = defer ns n mktac (DeferType n t a) = deferType n t a mktac (Instance n) = instanceArg n+ mktac (AutoArg n) = autoArg n mktac (SetInjective n) = setinj n mktac (MoveLast n) = movelast n
src/Idris/Core/ProofTerm.hs view
@@ -5,7 +5,7 @@ evaluation/checking inside the proof system, etc. --} module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm,- updateSolved, updateSolvedTerm, + updateSolved, updateSolvedTerm, updateSolvedTerm', bound_in, bound_in_term, refocus, Hole, RunTactic', goal, atHole) where@@ -124,13 +124,15 @@ hole _ = False updateSolvedTerm :: [(Name, Term)] -> Term -> Term -updateSolvedTerm [] x = x-updateSolvedTerm xs x = -- updateSolved' xs x where+updateSolvedTerm xs x = fst $ updateSolvedTerm' xs x++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 :).- fst $ updateSolved' xs x where+ updateSolved' xs x where updateSolved' [] x = (x, False) updateSolved' xs (Bind n (Hole ty) t) | Just v <- lookup n xs @@ -180,8 +182,8 @@ updateSolvedPath [] t = t updateSolvedPath ns Top = Top-updateSolvedPath ns (AppL p r) = AppL p (updateSolvedTerm ns r)-updateSolvedPath ns (AppR l p) = AppR (updateSolvedTerm ns l) p+updateSolvedPath ns (AppL p r) = AppL (updateSolvedPath ns p) (updateSolvedTerm ns r)+updateSolvedPath ns (AppR l p) = AppR (updateSolvedTerm ns l) (updateSolvedPath ns p) updateSolvedPath ns (InBind n b sc) = InBind n (updateSolvedPathB b) (updateSolvedTerm ns sc) where
− src/Idris/Core/TC.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}--module Idris.Core.TC(TC'(..)) where--import Control.Applicative-import Control.Monad-import Control.Monad.Trans.Error(Error(..))--data TC' e a = OK !a- | Error e- deriving (Eq, Functor)--bindTC :: TC' e a -> (a -> TC' e b) -> TC' e b-bindTC x k = case x of- OK v -> k v- Error e -> Error e-{-# INLINE bindTC #-}--instance Error e => Monad (TC' e) where- return x = OK x- x >>= k = bindTC x k - fail e = Error (strMsg e)--instance Error e => MonadPlus (TC' e) where- mzero = fail "Unknown error"- (OK x) `mplus` _ = OK x- _ `mplus` (OK y) = OK y- err `mplus` _ = err---instance Error e => Applicative (TC' e) where- pure = return- (<*>) = ap--instance Error e => Alternative (TC' e) where- empty = mzero- (<|>) = mplus
src/Idris/Core/TT.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor, DeriveDataTypeable #-} {-| TT is the core language of Idris. The language has: @@ -18,15 +18,16 @@ programs with implicit syntax into fully explicit terms. -} -module Idris.Core.TT(module Idris.Core.TT, module Idris.Core.TC) where--import Idris.Core.TC+module Idris.Core.TT where +import Control.Applicative (Applicative (..), Alternative)+import qualified Control.Applicative as A (Alternative (..)) import Control.Monad.State.Strict-import Control.Monad.Trans.Error (Error(..))+import Control.Monad.Trans.Except (Except (..)) import Debug.Trace import qualified Data.Map.Strict as Map import Data.Char+import Data.Data (Data) import Numeric (showIntAtBase) import qualified Data.Text as T import Data.List hiding (insert)@@ -34,6 +35,7 @@ import Data.Maybe (listToMaybe) import Data.Foldable (Foldable) import Data.Traversable (Traversable)+import Data.Typeable (Typeable) import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V import qualified Data.Binary as B@@ -51,6 +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) -- | Ignore source location equality (so deriving classes do not compare FCs) instance Eq FC where@@ -111,7 +114,7 @@ | NamePart Name | TermPart Term | SubReport [ErrorReportPart]- deriving (Show, Eq)+ deriving (Show, Eq, Data, Typeable) -- Please remember to keep Err synchronised with@@ -136,6 +139,7 @@ | TooManyArguments Name | CantIntroduce t | NoSuchVariable Name+ | WithFnType t | NoTypeDecl Name | NotInjective t t t | CantResolve t@@ -146,6 +150,7 @@ | UniqueKindError Universe Name | ProgramLineComment | Inaccessible Name+ | CantMatch t | NonCollapsiblePostulate Name | AlreadyDefined Name | ProofSearchFail (Err' t)@@ -157,10 +162,40 @@ | LoadingFailed String (Err' t) | ReflectionError [[ErrorReportPart]] (Err' t) | ReflectionFailed String (Err' t)- deriving (Eq, Functor)+ deriving (Eq, Functor, Data, Typeable) type Err = Err' Term +data TC a = OK !a+ | Error Err+ deriving (Eq, Functor)++bindTC :: TC a -> (a -> TC b) -> TC b+bindTC x k = case x of+ OK v -> k v+ Error e -> Error e+{-# INLINE bindTC #-}++instance Monad TC where+ return x = OK x+ x >>= k = bindTC x k + fail e = Error (InternalMsg e)++instance MonadPlus TC where+ mzero = fail "Unknown error"+ (OK x) `mplus` _ = OK x+ _ `mplus` (OK y) = OK y+ err `mplus` _ = err+++instance Applicative TC where+ pure = return+ (<*>) = ap++instance Alternative TC where+ empty = mzero+ (<|>) = mplus+ {-! deriving instance NFData Err !-}@@ -209,7 +244,7 @@ instance Show Err where show (Msg s) = s show (InternalMsg s) = "Internal error: " ++ show s- show (CantUnify rec l r e sc i) = "CantUnify " ++ show rec ++ " " +++ show (CantUnify rcv l r e sc i) = "CantUnify " ++ show rcv ++ " " ++ show l ++ " " ++ show r ++ " " ++ show e ++ " in " ++ show sc ++ " " ++ show i show (CantSolveGoal g _) = "CantSolve " ++ show g@@ -233,11 +268,6 @@ pretty err@(LoadingFailed _ _) = text (show err) pretty _ = text "Error" -instance Error Err where- strMsg = InternalMsg--type TC = TC' Err- instance (Pretty a OutputAnnotation) => Pretty (TC a) OutputAnnotation where pretty (OK ok) = pretty ok pretty (Error err) =@@ -280,7 +310,7 @@ | NErased -- ^ Name of something which is never used in scope | SN SpecialName -- ^ Decorated function names | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)- deriving (Eq, Ord)+ deriving (Eq, Ord, Data, Typeable) txt :: String -> T.Text txt = T.pack@@ -317,7 +347,7 @@ | CaseN Name | ElimN Name | InstanceCtorN Name- deriving (Eq, Ord)+ deriving (Eq, Ord, Data, Typeable) {-! deriving instance Binary SpecialName deriving instance NFData SpecialName@@ -467,7 +497,7 @@ addAlist ((n, tm) : ds) ctxt = addDef n tm (addAlist ds ctxt) data NativeTy = IT8 | IT16 | IT32 | IT64- deriving (Show, Eq, Ord, Enum)+ deriving (Show, Eq, Ord, Enum, Data, Typeable) instance Pretty NativeTy OutputAnnotation where pretty IT8 = text "Bits8"@@ -477,7 +507,7 @@ data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar | ITVec NativeTy Int- deriving (Show, Eq, Ord)+ deriving (Show, Eq, Ord, Data, Typeable) intTyName :: IntTy -> String intTyName ITNative = "Int"@@ -486,8 +516,8 @@ intTyName (ITChar) = "Char" intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show count -data ArithTy = ATInt IntTy | ATFloat -- TODO: Float vectors- deriving (Show, Eq, Ord)+data ArithTy = ATInt IntTy | ATFloat -- TODO: Float vectors https://github.com/idris-lang/Idris-dev/issues/1723+ deriving (Show, Eq, Ord, Data, Typeable) {-! deriving instance NFData IntTy deriving instance NFData NativeTy@@ -521,12 +551,21 @@ | B32V (Vector Word32) | B64V (Vector Word64) | AType ArithTy | StrType | PtrType | ManagedPtrType | BufferType | VoidType | Forgot- deriving (Eq, Ord)+ deriving (Eq, Ord, Data, Typeable) {-! deriving instance Binary Const deriving instance NFData Const !-} +isTypeConst :: Const -> Bool+isTypeConst (AType _) = True+isTypeConst StrType = True+isTypeConst ManagedPtrType = True+isTypeConst BufferType = True+isTypeConst PtrType = True+isTypeConst VoidType = True+isTypeConst _ = False+ instance Sized Const where size _ = 1 @@ -603,7 +642,7 @@ constDocs prim = "Undocumented" data Universe = NullType | UniqueType | AllTypes- deriving (Eq, Ord)+ deriving (Eq, Ord, Data, Typeable) instance Show Universe where show UniqueType = "UniqueType"@@ -617,7 +656,7 @@ | RUType Universe | RForce Raw | RConstant Const- deriving (Show, Eq)+ deriving (Show, Eq, Data, Typeable) instance Sized Raw where size (Var name) = 1@@ -636,6 +675,14 @@ deriving instance NFData Raw !-} +data ImplicitInfo = Impl { tcinstance :: Bool }+ deriving (Show, Eq, Ord, Data, Typeable)++{-!+deriving instance Binary ImplicitInfo+deriving instance NFData ImplicitInfo+!-}+ -- The type parameter `b` will normally be something like `TT Name` or just -- `Raw`. We do not make a type-level distinction between TT terms that happen -- to be TT types and TT terms that are not TT types.@@ -643,9 +690,13 @@ -- the types of bindings (and their values, if any); the attached identifiers are part -- of the 'Bind' constructor for the 'TT' type. data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}}- | Pi { binderTy :: !b,+ | Pi { binderImpl :: Maybe ImplicitInfo,+ binderTy :: !b, binderKind :: !b }- {-^ A binding that occurs in a function type expression, e.g. @(x:Int) -> ...@ -}+ {-^ A binding that occurs in a function type expression, e.g. @(x:Int) -> ...@+ The 'binderImpl' flag says whether it was a scoped implicit+ (i.e. forall bound) in the high level Idris, but otherwise+ has no relevance in TT. -} | Let { binderTy :: !b, binderVal :: b {-^ value for bound variable-}} -- ^ A binding that occurs in a @let@ expression@@ -659,7 +710,7 @@ | PVar { binderTy :: !b } -- ^ A pattern variable | PVTy { binderTy :: !b }- deriving (Show, Eq, Ord, Functor, Foldable, Traversable)+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Data, Typeable) {-! deriving instance Binary Binder deriving instance NFData Binder@@ -667,7 +718,7 @@ instance Sized a => Sized (Binder a) where size (Lam ty) = 1 + size ty- size (Pi ty _) = 1 + size ty+ size (Pi _ ty _) = 1 + size ty size (Let ty val) = 1 + size ty + size val size (NLet ty val) = 1 + size ty + size val size (Hole ty) = 1 + size ty@@ -681,7 +732,7 @@ fmapMB f (NLet t v) = liftM2 NLet (f t) (f v) fmapMB f (Guess t v) = liftM2 Guess (f t) (f v) fmapMB f (Lam t) = liftM Lam (f t)-fmapMB f (Pi t k) = liftM2 Pi (f t) (f k)+fmapMB f (Pi i t k) = liftM2 (Pi i) (f t) (f k) fmapMB f (Hole t) = liftM Hole (f t) fmapMB f (GHole i t) = liftM (GHole i) (f t) fmapMB f (PVar t) = liftM PVar (f t)@@ -701,7 +752,7 @@ -- | Universe expressions for universe checking data UExp = UVar Int -- ^ universe variable | UVal Int -- ^ explicit universe level- deriving (Eq, Ord)+ deriving (Eq, Ord, Data, Typeable) {-! deriving instance NFData UExp !-}@@ -738,7 +789,7 @@ | Ref | DCon {nt_tag :: Int, nt_arity :: Int, nt_unique :: Bool} -- ^ Data constructor | TCon {nt_tag :: Int, nt_arity :: Int} -- ^ Type constructor- deriving (Show, Ord)+ deriving (Show, Ord, Data, Typeable) {-! deriving instance Binary NameType deriving instance NFData NameType@@ -773,7 +824,7 @@ | Impossible -- ^ special case for totality checking | TType UExp -- ^ the type of types at some level | UType Universe -- ^ Uniqueness type universe (disjoint from TType)- deriving (Ord, Functor)+ deriving (Ord, Functor, Data, Typeable) {-! deriving instance Binary TT deriving instance NFData TT@@ -792,7 +843,7 @@ | otherwise = 1 termsize n (V _) = 1 -- for `Bind` terms, we can erroneously declare a term- -- "recursive => really big" if the name of the bound + -- "recursive => really big" if the name of the bound -- variable is the same as the name we're using -- So generate a different name in that case. termsize n (Bind n' (Let t v) sc)@@ -848,7 +899,7 @@ isInjective (P (TCon _ _) _ _) = True isInjective (Constant _) = True isInjective (TType x) = True-isInjective (Bind _ (Pi _ _) sc) = True+isInjective (Bind _ (Pi _ _ _) sc) = True isInjective (App f a) = isInjective f isInjective _ = False @@ -971,19 +1022,19 @@ subst' i t@(Bind x b sc) | x /= n = let (b', ub) = substB' i b (sc', usc) = subst' (i+1) sc in- if ub || usc then (Bind x b' sc', True) else (t, False) - subst' i t@(App f a) = let (f', uf) = subst' i f + if ub || usc then (Bind x b' sc', True) else (t, False)+ subst' i t@(App f a) = let (f', uf) = subst' i f (a', ua) = subst' i a in if uf || ua then (App f' a', True) else (t, False) subst' i t@(Proj x idx) = let (x', u) = subst' i x in if u then (Proj x' idx, u) else (t, False) subst' i t = (t, False) - substB' i b@(Let t v) = let (t', ut) = subst' i t + substB' i b@(Let t v) = let (t', ut) = subst' i t (v', uv) = subst' i v in if ut || uv then (Let t' v', True) else (b, False)- substB' i b@(Guess t v) = let (t', ut) = subst' i t + substB' i b@(Guess t v) = let (t', ut) = subst' i t (v', uv) = subst' i v in if ut || uv then (Guess t' v', True) else (b, False)@@ -1051,17 +1102,19 @@ -- | Returns all names used free in the term freeNames :: Eq n => TT n -> [n]-freeNames (P _ n _) = [n]-freeNames (Bind n (Let t v) sc) = nub $ freeNames v ++ (freeNames sc \\ [n])- ++ freeNames t-freeNames (Bind n b sc) = nub $ freeNames (binderTy b) ++ (freeNames sc \\ [n])-freeNames (App f a) = nub $ freeNames f ++ freeNames a-freeNames (Proj x i) = nub $ freeNames x-freeNames _ = []+freeNames t = nub $ freeNames' t+ where+ freeNames' (P _ n _) = [n]+ freeNames' (Bind n (Let t v) sc) = freeNames' v ++ (freeNames' sc \\ [n])+ ++ freeNames' t+ freeNames' (Bind n b sc) = freeNames' (binderTy b) ++ (freeNames' sc \\ [n])+ freeNames' (App f a) = freeNames' f ++ freeNames' a+ freeNames' (Proj x i) = freeNames' x+ freeNames' _ = [] -- | Return the arity of a (normalised) type arity :: TT n -> Int-arity (Bind n (Pi t _) sc) = 1 + arity sc+arity (Bind n (Pi _ t _) sc) = 1 + arity sc arity _ = 0 -- | Deconstruct an application; returns the function and a list of arguments@@ -1090,7 +1143,7 @@ -- Bruijn indices. forget :: TT Name -> Raw forget tm = forgetEnv [] tm- + forgetEnv :: [Name] -> TT Name -> Raw forgetEnv env (P _ n _) = Var n forgetEnv env (V i) = Var (env !! i)@@ -1119,16 +1172,19 @@ -- | Return a list of pairs of the names of the outermost 'Pi'-bound -- variables in the given term, together with their types. getArgTys :: TT n -> [(n, TT n)]-getArgTys (Bind n (Pi t _) sc) = (n, t) : getArgTys sc+getArgTys (Bind n (PVar _) sc) = getArgTys sc+getArgTys (Bind n (PVTy _) sc) = getArgTys sc+getArgTys (Bind n (Pi _ t _) sc) = (n, t) : getArgTys sc getArgTys _ = [] getRetTy :: TT n -> TT n getRetTy (Bind n (PVar _) sc) = getRetTy sc getRetTy (Bind n (PVTy _) sc) = getRetTy sc-getRetTy (Bind n (Pi _ _) sc) = getRetTy sc+getRetTy (Bind n (Pi _ _ _) sc) = getRetTy sc getRetTy sc = sc uniqueNameFrom :: [Name] -> [Name] -> Name+uniqueNameFrom [] hs = uniqueName (nextName (sUN "x")) hs uniqueNameFrom (s : supply) hs | s `elem` hs = uniqueNameFrom supply hs | otherwise = s@@ -1164,8 +1220,12 @@ where nextName' (WhereN i f x) = WhereN i f (nextName x) nextName' (WithN i n) = WithN i (nextName n)+ nextName' (InstanceN n ns) = InstanceN (nextName n) ns+ nextName' (ParentN n ns) = ParentN (nextName n) ns nextName' (CaseN n) = CaseN (nextName n)+ nextName' (ElimN n) = ElimN (nextName n) nextName' (MethodN n) = MethodN (nextName n)+ nextName' (InstanceCtorN n) = InstanceCtorN (nextName n) type Term = TT Name type Type = Term@@ -1237,7 +1297,7 @@ else lbracket <+> text (show i) <+> rbracket | otherwise = text "unbound" <+> text (show i) <+> text "!"- prettySe p env (Bind n b@(Pi t _) sc) debug+ prettySe p env (Bind n b@(Pi _ t _) sc) debug | noOccurrence n sc && not debug = bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug prettySe p env (Bind n b sc) debug =@@ -1253,7 +1313,7 @@ -- Render a `Binder` and its name prettySb env n (Lam t) = prettyB env "λ" "=>" n t prettySb env n (Hole t) = prettyB env "?defer" "." n t- prettySb env n (Pi t _) = prettyB env "(" ") ->" n t+ prettySb env n (Pi _ t _) = prettyB env "(" ") ->" n t prettySb env n (PVar t) = prettyB env "pat" "." n t prettySb env n (PVTy t) = prettyB env "pty" "." n t prettySb env n (Let t v) = prettyBv env "let" "in" n t v@@ -1279,7 +1339,7 @@ = (show $ fst $ env!!i) ++ if dbg then "{" ++ show i ++ "}" else "" | otherwise = "!!V " ++ show i ++ "!!"- se p env (Bind n b@(Pi t k) 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 _) = " -> " arrow u = " [" ++ show u ++ "] -> "@@ -1295,7 +1355,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 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 sb env n (Let t v) = showbv env "let " " in " n t v@@ -1355,36 +1415,37 @@ op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc- op ps (Bind n (Pi t k) sc) = op ((n, Pi t k) : ps) sc+ op ps (Bind n (Pi i t k) sc) = op ((n, Pi i t k) : ps) sc op ps sc = bindAll (sortP ps) sc sortP ps = pick [] (reverse ps) - namesIn (P _ n _) = [n]- namesIn (Bind n b t) = nub $ nb b ++ (namesIn t \\ [n])- where nb (Let t v) = nub (namesIn t) ++ nub (namesIn v)- nb (Guess t v) = nub (namesIn t) ++ nub (namesIn v)- nb t = namesIn (binderTy t)- namesIn (App f a) = nub (namesIn f ++ namesIn a)- namesIn _ = []- pick acc [] = reverse acc pick acc ((n, t) : ps) = pick (insert n t acc) ps insert n t [] = [(n, t)] insert n t ((n',t') : ps)- | n `elem` (namesIn (binderTy t') ++- concatMap namesIn (map (binderTy . snd) ps))+ | n `elem` (refsIn (binderTy t') +++ concatMap refsIn (map (binderTy . snd) ps)) = (n', t') : insert n t ps | otherwise = (n,t):(n',t'):ps +refsIn :: TT Name -> [Name]+refsIn (P _ n _) = [n]+refsIn (Bind n b t) = nub $ nb b ++ refsIn t+ where nb (Let t v) = nub (refsIn t) ++ nub (refsIn v)+ nb (Guess t v) = nub (refsIn t) ++ nub (refsIn v)+ nb t = refsIn (binderTy t)+refsIn (App f a) = nub (refsIn f ++ refsIn a)+refsIn _ = []+ -- Make sure all the pattern bindings are as far out as possible liftPats :: Term -> Term liftPats tm = let (tm', ps) = runState (getPats tm) [] in orderPats $ bindPats (reverse ps) tm' where bindPats [] tm = tm- bindPats ((n, t):ps) tm + bindPats ((n, t):ps) tm | n `notElem` map fst ps = Bind n (PVar t) (bindPats ps tm) | otherwise = bindPats ps tm @@ -1400,10 +1461,10 @@ v' <- getPats v sc' <- getPats sc return (Bind n (Let t' v') sc')- getPats (Bind n (Pi t k) sc) = do t' <- getPats t- k' <- getPats k- sc' <- getPats sc- return (Bind n (Pi t' k') sc')+ getPats (Bind n (Pi i t k) sc) = do t' <- getPats t+ k' <- getPats k+ sc' <- getPats sc+ return (Bind n (Pi i t' k') sc') getPats (Bind n (Lam t) sc) = do t' <- getPats t sc' <- getPats sc return (Bind n (Lam t') sc')
src/Idris/Core/Typecheck.hs view
@@ -53,7 +53,7 @@ recheck :: Context -> Env -> Raw -> Term -> TC (Term, Type, UCs) recheck = recheck_borrowing False [] -recheck_borrowing :: Bool -> [Name] -> Context -> Env -> Raw -> Term -> +recheck_borrowing :: Bool -> [Name] -> Context -> Env -> Raw -> Term -> TC (Term, Type, UCs) recheck_borrowing uniq_check bs ctxt env tm orig = let v = next_tvar ctxt in@@ -65,7 +65,7 @@ return (tm, ty, constraints) check :: Context -> Env -> Raw -> TC (Term, Type)-check ctxt env tm +check ctxt env tm = evalStateT (check' True ctxt env tm) (0, []) -- Holes allowed check' :: Bool -> Context -> Env -> Raw -> StateT UCs TC (Term, Type)@@ -87,18 +87,18 @@ = do (fv, fty) <- chk u env f (av, aty) <- chk u env a let fty' = case uniqueBinders (map fst env) (finalise fty) of- ty@(Bind x (Pi s k) t) -> ty+ ty@(Bind x (Pi i s k) t) -> ty _ -> uniqueBinders (map fst env) $ case hnf ctxt env fty of- ty@(Bind x (Pi s k) t) -> ty+ ty@(Bind x (Pi i s k) t) -> ty _ -> normalise ctxt env fty case fty' of- Bind x (Pi s k) t -> + Bind x (Pi i s k) t -> do convertsC ctxt env aty s let apty = simplify initContext env (Bind x (Let aty av) t) return (App fv av, apty)- t -> lift $ tfail $ NonFunctionType fv fty + t -> lift $ tfail $ NonFunctionType fv fty chk u env RType | holes = return (TType (UVal 0), TType (UVal 0)) | otherwise = do (v, cs) <- get@@ -107,7 +107,9 @@ return (TType (UVar v), TType (UVar (v+1))) chk u env (RUType un) | holes = return (UType un, TType (UVal 0))- | otherwise = do -- TODO! (v, cs) <- get+ | otherwise = do -- TODO! Issue #1715 on the issue tracker.+ -- https://github.com/idris-lang/Idris-dev/issues/1715+ -- (v, cs) <- get -- let c = ULT (UVar v) (UVar (v+1)) -- put (v+2, (c:cs)) -- return (TType (UVar v), TType (UVar (v+1)))@@ -131,36 +133,35 @@ constType _ = TType (UVal 0) chk u env (RForce t) = do (_, ty) <- chk u env t return (Erased, ty)- chk u env (RBind n (Pi s k) t)+ chk u env (RBind n (Pi i s k) t) = do (sv, st) <- chk u env s (kv, kt) <- chk u env k- (tv, tt) <- chk st ((n, Pi sv kv) : env) t--- let tv = mkUniquePi kv tv_in+ (tv, tt) <- chk st ((n, Pi i sv kv) : env) t (v, cs) <- get case (normalise ctxt env st, normalise ctxt env tt) of (TType su, TType tu) -> do when (not holes) $ put (v+1, ULE su (UVar v):ULE tu (UVar v):cs) let k' = st `smaller` kv `smaller` TType (UVar v) `smaller` u- return (Bind n (Pi (uniqueBinders (map fst env) sv) k')+ return (Bind n (Pi i (uniqueBinders (map fst env) sv) k') (pToV n tv), k') (un, un') -> let k' = st `smaller` kv `smaller` un `smaller` un' `smaller` u in- return (Bind n (Pi (uniqueBinders (map fst env) sv) k')+ return (Bind n (Pi i (uniqueBinders (map fst env) sv) k') (pToV n tv), k') - where mkUniquePi kv (Bind n (Pi s k) sc) + where mkUniquePi kv (Bind n (Pi i s k) sc) = let k' = smaller kv k in- Bind n (Pi s k') (mkUniquePi k' sc)- mkUniquePi kv (Bind n (Lam t) sc) + Bind n (Pi i s k') (mkUniquePi k' sc)+ mkUniquePi kv (Bind n (Lam t) sc) = Bind n (Lam (mkUniquePi kv t)) (mkUniquePi kv sc)- mkUniquePi kv (Bind n (Let t v) sc) + mkUniquePi kv (Bind n (Let t v) sc) = Bind n (Let (mkUniquePi kv t) v) (mkUniquePi kv sc) mkUniquePi kv t = t -- Kind of the whole thing is the kind of the most unique thing -- in the environment (because uniqueness taints everything...) mostUnique [] k = k- mostUnique (Pi _ pk : es) k = mostUnique es (smaller pk k)+ mostUnique (Pi _ _ pk : es) k = mostUnique es (smaller pk k) mostUnique (_ : es) k = mostUnique es k chk u env (RBind n b sc)@@ -229,9 +230,9 @@ return (PVTy tv, tt') discharge n (Lam t) bt scv sct- = return (Bind n (Lam t) scv, Bind n (Pi t bt) sct)- discharge n (Pi t k) bt scv sct- = return (Bind n (Pi t k) scv, sct)+ = return (Bind n (Lam t) scv, Bind n (Pi Nothing t bt) sct)+ discharge n (Pi i t k) bt scv sct+ = return (Bind n (Pi i t k) scv, sct) discharge n (Let t v) bt scv sct = return (Bind n (Let t v) scv, Bind n (Let t v) sct) discharge n (NLet t v) bt scv sct@@ -257,9 +258,9 @@ -- If any binders are of kind 'UniqueType' or 'AllTypes' and the name appears -- in the scope more than once, this is an error. checkUnique :: [Name] -> Context -> Env -> Term -> TC ()-checkUnique borrowed ctxt env tm +checkUnique borrowed ctxt env tm = evalStateT (chkBinders env (explicitNames tm)) []- where + where isVar (P _ _ _) = True isVar (V _) = True isVar _ = False@@ -272,10 +273,10 @@ chkBinders env (App (App (P _ (NS (UN lend) [owner]) _) t) a) | isVar a && owner == txt "Ownership" && (lend == txt "lend" || lend == txt "Read")- = do chkBinders env t -- Check the type normally + = do chkBinders env t -- Check the type normally st <- get -- Remove the 'LendOnly' names from the unusable set- put (filter (\(n, (ok, _)) -> ok /= LendOnly) st) + put (filter (\(n, (ok, _)) -> ok /= LendOnly) st) chkBinders env a put st -- Reset the old state after checking the argument chkBinders env (App f a) = do chkBinders env f; chkBinders env a@@ -288,14 +289,16 @@ chkBinders ((n, b) : env) t chkBinders env t = return () - chkBinderName :: Env -> Name -> Binder Term -> + chkBinderName :: Env -> Name -> Binder Term -> StateT [(Name, (UniqueUse, Universe))] TC () chkBinderName env n b = do let rawty = forgetEnv (map fst env) (binderTy b) (_, kind) <- lift $ check ctxt env rawty -- FIXME: Cache in binder?+ -- Issue #1714 on the issue tracker+ -- https://github.com/idris-lang/Idris-dev/issues/1714 case kind of UType UniqueType -> do ns <- get- if n `elem` borrowed + if n `elem` borrowed then put ((n, (LendOnly, NullType)) : ns) else put ((n, (Once, UniqueType)) : ns) UType NullType -> do ns <- get@@ -304,13 +307,12 @@ put ((n, (Once, AllTypes)) : ns) _ -> return () - chkName n + chkName n = do ns <- get case lookup n ns of Nothing -> return () Just (Many, k) -> return () Just (Never, k) -> lift $ tfail (UniqueError k n) Just (LendOnly, k) -> lift $ tfail (UniqueError k n)- Just (Once, k) -> put ((n, (Never, k)) : + Just (Once, k) -> put ((n, (Never, k)) : filter (\x -> fst x /= n) ns)-
src/Idris/Core/Unify.hs view
@@ -29,11 +29,13 @@ deriving (Eq, Show) type Injs = [(TT Name, TT Name, TT Name)]-type Fails = [(TT Name, TT Name, Env, Err, [FailContext], FailAt)]+type Fails = [(TT Name, TT Name, -- unification error+ Bool, -- ready to retry yet+ Env, Err, [FailContext], FailAt)] unrecoverable :: Fails -> Bool-unrecoverable = any bad - where bad (_,_,_, err, _, _) = unrec err+unrecoverable = any bad+ where bad (_,_,_,_, err, _, _) = unrec err unrec (CantUnify r _ _ _ _ _) = not r unrec (At _ e) = unrec e@@ -64,40 +66,54 @@ match_unify ctxt env topx topy inj holes from = case runStateT (un [] (renameBindersTm env topx) (renameBindersTm env topy)) (UI 0 []) of- OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v))+ OK (v, UI _ []) -> + do v' <- trimSolutions topx topy from env v+ return (map (renameBinders env) v') res -> let topxn = renameBindersTm env (normalise ctxt env topx) topyn = renameBindersTm env (normalise ctxt env topy) in case runStateT (un [] topxn topyn)- (UI 0 []) of+ (UI 0 []) of OK (v, UI _ fails) ->- return (map (renameBinders env) (trimSolutions v))+ do v' <- trimSolutions topx topy 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+ (UI 0 []) of OK (v, UI _ fails) ->- return (map (renameBinders env) (trimSolutions v))+ do v' <- trimSolutions topx topy from env v+ return (map (renameBinders env) v') _ -> tfail e where- -- This rule is highly dubious... it certainly produces a valid answer- -- but it scares me. However, matching is never guaranteed to give a unique- -- answer, merely a valid one, so perhaps we're okay.- -- In other words: it may vanish without warning some day :) un :: [((Name, Name), TT Name)] -> TT Name -> TT Name -> StateT UInfo TC [(Name, TT Name)] - un names x tm@(App (P _ f (Bind fn (Pi t _) sc)) a)+ -- This rule is highly dubious... it certainly produces a valid answer+ -- but it scares me. However, matching is never guaranteed to give a unique+ -- answer, merely a valid one, so perhaps we're okay.+ -- In other words: it may vanish without warning some day :)+ un names x tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a)+ | (P (TCon _ _) _ _, _) <- unApply x,+ holeIn env f || f `elem` holes+ = let n' = uniqueName (sMN 0 "mv") (map fst env) in+ checkCycle names (f, Bind n' (Lam t) x)+ un names tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) x+ | (P (TCon _ _) _ _, _) <- unApply x,+ holeIn env f || f `elem` holes+ = let n' = uniqueName fn (map fst env) in+ checkCycle names (f, Bind n' (Lam t) x)+ un names x tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) | (P (DCon _ _ _) _ _, _) <- unApply x, holeIn env f || f `elem` holes = let n' = uniqueName (sMN 0 "mv") (map fst env) in- checkCycle names (f, Bind n' (Lam t) x) - un names tm@(App (P _ f (Bind fn (Pi t _) sc)) a) x+ 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 = let n' = uniqueName fn (map fst env) in- checkCycle names (f, Bind n' (Lam t) x) + checkCycle names (f, Bind n' (Lam t) x) un names tx@(P _ x _) tm | tx /= tm && holeIn env x || x `elem` holes@@ -106,12 +122,12 @@ | ty /= tm && holeIn env y || y `elem` holes = do sc 1; checkCycle names (y, tm) un bnames (V i) (P _ x _)- | length bnames > i, - fst (fst (bnames!!i)) == x || + | length bnames > i,+ fst (fst (bnames!!i)) == x || snd (fst (bnames!!i)) == x = do sc 1; return [] un bnames (P _ x _) (V i) | length bnames > i,- fst (fst (bnames!!i)) == x || + fst (fst (bnames!!i)) == x || snd (fst (bnames!!i)) == x = do sc 1; return [] un bnames (Bind x bx sx) (Bind y by sy) | notHole bx && notHole by = do h1 <- uB bnames bx by@@ -124,12 +140,12 @@ un names x y | OK True <- convEq' ctxt holes x y = do sc 1; return [] | otherwise = do UI s f <- get- let r = recoverable (normalise ctxt env x) + 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 if (not r) then lift $ tfail err- else do put (UI s ((x, y, env, err, from, Match) : f))+ else do put (UI s ((x, y, True, env, err, from, Match) : f)) lift $ tfail err @@ -137,14 +153,16 @@ 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 _ tx _) (Pi _ ty _) = un bnames tx ty uB bnames x y = do UI s f <- get- let r = recoverable (normalise ctxt env (binderTy x)) + 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) (errEnv env) s- put (UI s ((binderTy x, binderTy y, env, err, from, Match) : f))+ put (UI s ((binderTy x, binderTy y, + False,+ env, err, from, Match) : f)) return [] notHole (Hole _) = False@@ -152,16 +170,17 @@ -- TODO: there's an annoying amount of repetition between this and the -- main unification function. Consider lifting it out.+ -- Issue #1721 on the issue tracker: https://github.com/idris-lang/Idris-dev/issues/1721 sc i = do UI s f <- get put (UI (s+i) f) unifyFail x y = do UI s f <- get- let r = recoverable (normalise ctxt env x) + 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- put (UI s ((x, y, env, err, from, Match) : f))+ put (UI s ((x, y, True, env, err, from, Match) : f)) lift $ tfail err combine bnames as [] = return as combine bnames as ((n, t) : bs)@@ -192,23 +211,23 @@ where inst [] tm = tm inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm) - bind i ns tm + bind i ns tm | i < 0 = tm | otherwise = let ((x,y),ty) = ns!!i in App (Bind y (Lam ty) (bind (i-1) ns tm)) (P Bound x ty)- + renameBinders env (x, t) = (x, renameBindersTm env t) renameBindersTm :: Env -> TT Name -> TT Name renameBindersTm env tm = uniqueBinders (map fst env) tm where uniqueBinders env (Bind n b sc)- | n `elem` env + | n `elem` env = let n' = uniqueName n env in explicitHole $ Bind n' (fmap (uniqueBinders env) b) (uniqueBinders (n':env) (rename n n' sc))- | otherwise = Bind n (fmap (uniqueBinders (n:env)) b) + | otherwise = Bind n (fmap (uniqueBinders (n:env)) b) (uniqueBinders (n:env) sc) uniqueBinders env (App f a) = App (uniqueBinders env f) (uniqueBinders env a) uniqueBinders env t = t@@ -218,26 +237,34 @@ rename n n' (App f a) = App (rename n n' f) (rename n n' a) rename n n' t = t - explicitHole (Bind n (Hole ty) sc) + explicitHole (Bind n (Hole ty) sc) = Bind n (Hole ty) (instantiate (P Bound n ty) sc) explicitHole t = t -trimSolutions ns = followSols (dropPairs ns)+trimSolutions topx topy from env topns = followSols [] (dropPairs topns) where dropPairs [] = [] dropPairs (n@(x, P _ x' _) : ns) | x == x' = dropPairs ns | otherwise- = n : dropPairs + = n : dropPairs (filter (\t -> case t of (n, P _ n' _) -> not (n == x' && n' == x) _ -> True) ns) dropPairs (n : ns) = n : dropPairs ns - followSols [] = []- followSols ((n, P _ t _) : ns)+ followSols vs [] = return []+ followSols vs ((n, P _ t _) : ns) | Just t' <- lookup t ns- = followSols ((n, t') : ns) -- Are we guaranteed no cycles?- followSols (n : ns) = n : followSols ns+ = do vs' <- case t' of+ P _ tn _ -> + if (n, tn) `elem` vs then -- cycle+ tfail (cantUnify from False topx topy + (Msg "") (errEnv env) 0)+ else return ((n, tn) : vs)+ _ -> return vs+ followSols vs' ((n, t') : ns) + followSols vs (n : ns) = do ns' <- followSols vs ns+ return $ n : ns' expandLets env (x, tm) = (x, doSubst (reverse env) tm) where@@ -253,28 +280,28 @@ hasv (Bind x b sc) = hasv (binderTy b) || hasv sc hasv _ = False -unify :: Context -> Env -> TT Name -> TT Name -> +unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [Name] -> [FailContext] -> TC ([(Name, TT Name)], Fails) unify ctxt env topx topy inj holes usersupp from =--- traceWhen (hasv topx || hasv topy) +-- 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) + case runStateT (un False [] (renameBindersTm env topx) (renameBindersTm env topy)) (UI 0 []) of- OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v),- [])+ OK (v, UI _ []) -> do v' <- trimSolutions topx topy from env v+ return (map (renameBinders env) v', []) res -> let topxn = renameBindersTm env (normalise ctxt env topx) topyn = renameBindersTm env (normalise ctxt env topy) in -- trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n" ++ show res ++ "\n\n") $ case runStateT (un False [] topxn topyn)- (UI 0 []) of+ (UI 0 []) of OK (v, UI _ fails) ->- return (map (renameBinders env) (trimSolutions v), - reverse fails)+ do v' <- trimSolutions topx topy from env v+ return (map (renameBinders env) v', reverse fails) -- Error e@(CantUnify False _ _ _ _ _) -> tfail e- Error e -> tfail e+ Error e -> tfail e where headDiff (P (DCon _ _ _) x _) (P (DCon _ _ _) y _) = x /= y headDiff (P (TCon _ _) x _) (P (TCon _ _) y _) = x /= y@@ -287,8 +314,8 @@ injective (App f a) = injective f -- && injective a injective _ = False --- injectiveVar (P _ (MN _ _) _) = True -- TMP HACK - injectiveVar (P _ n _) = n `elem` inj +-- injectiveVar (P _ (MN _ _) _) = True -- TMP HACK+ injectiveVar (P _ n _) = n `elem` inj injectiveVar (App f a) = injectiveVar f -- && injective a injectiveVar _ = False @@ -364,7 +391,7 @@ then unifyTmpFail xtm tm else do sc 1 return x- | pureTerm tm, not (injective xtm) && injective tm + | pureTerm tm, not (injective xtm) && injective tm = do checkCycle bnames (x, tm) unifyTmpFail xtm tm un' fn bnames tm ytm@(P _ y _)@@ -378,16 +405,16 @@ then unifyTmpFail tm ytm else do sc 1 return x- | pureTerm tm, not (injective ytm) && injective tm + | pureTerm tm, not (injective ytm) && injective tm = do checkCycle bnames (y, tm) unifyTmpFail tm ytm un' fn bnames (V i) (P _ x _) | length bnames > i,- fst ((map fst bnames)!!i) == x || + fst ((map fst bnames)!!i) == x || snd ((map fst bnames)!!i) == x = do sc 1; return [] un' fn bnames (P _ x _) (V i) | length bnames > i,- fst ((map fst bnames)!!i) == x || + fst ((map fst bnames)!!i) == x || snd ((map fst bnames)!!i) == x = do sc 1; return [] un' fn names topx@(Bind n (Hole t) sc) y = unifyTmpFail topx y@@ -414,41 +441,45 @@ -- f D unifies with t -> D. This is dubious, but it helps with type -- class resolution for type classes over functions. - un' fn bnames (App f x) (Bind n (Pi t k) y)+ un' fn bnames (App f x) (Bind n (Pi i t k) y) | noOccurrence n y && injectiveApp f = do ux <- un' False bnames x y- uf <- un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) - (Bind n (Pi t k) (V 1)))+ uf <- un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))+ (Bind n (Pi i t k) (V 1))) combine bnames ux uf- - un' fn bnames (Bind n (Pi t k) y) (App f x)++ un' fn bnames (Bind n (Pi i t k) y) (App f x) | noOccurrence n y && injectiveApp f = do ux <- un' False bnames y x- uf <- un' False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) - (Bind n (Pi t k) (V 1))) f+ uf <- un' False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))+ (Bind n (Pi i t k) (V 1))) f combine bnames ux uf- + un' fn bnames (Bind x bx sx) (Bind y by sy) | sameBinder bx by = do h1 <- uB bnames bx by h2 <- un' False (((x,y),binderTy bx):bnames) sx sy combine bnames h1 h2 where sameBinder (Lam _) (Lam _) = True- sameBinder (Pi _ _) (Pi _ _) = True+ sameBinder (Pi _ _ _) (Pi _ _ _) = True sameBinder _ _ = False un' fn bnames x y | OK True <- convEq' ctxt holes x y = do sc 1; return []- | isUniverse x && isUniverse y = do sc 1; return [] + | isUniverse x && isUniverse y = do sc 1; return [] | otherwise = do UI s f <- get- let r = recoverable (normalise ctxt env x) + 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 if (not r) then lift $ tfail err- else do put (UI s ((x, y, env, err, from, Unify) : f))+ else do put (UI s ((x, y, True, env, err, from, Unify) : f)) return [] -- lift $ tfail err unApp fn bnames appx@(App fx ax) appy@(App fy ay)+ -- shortcut for the common case where we just want to check the+ -- arguments are correct+ | (injectiveApp fx && fx == fy)+ = un' False bnames ax ay | (injectiveApp fx && injectiveApp fy) || (injectiveApp fx && metavarApp fy && ax == ay) || (injectiveApp fy && metavarApp fx && ax == ay)@@ -519,7 +550,7 @@ _ -> False metavar t = case t of- P _ x _ -> (x `notElem` usersupp && + P _ x _ -> (x `notElem` usersupp && (x `elem` holes || holeIn env x)) || globmetavar t _ -> False@@ -539,7 +570,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- put (UI s ((topx, topy, env, err, from, Unify) : f))+ put (UI s ((topx, topy, True, env, err, from, Unify) : f)) return [] -- shortcut failure, if we *know* nothing can fix it@@ -547,7 +578,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- put (UI s ((topx, topy, env, err, from, Unify) : f))+ put (UI s ((topx, topy, True, env, err, from, Unify) : f)) lift $ tfail err @@ -562,16 +593,18 @@ sc 1 combine bnames h1 h2 uB bnames (Lam tx) (Lam ty) = do sc 1; un' False bnames tx ty- uB bnames (Pi tx _) (Pi ty _) = do sc 1; un' False bnames tx ty+ uB bnames (Pi _ tx _) (Pi _ ty _) = do sc 1; un' False bnames tx ty uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty uB bnames x y = do UI s f <- get- let r = recoverable (normalise ctxt env (binderTy x)) + 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) (errEnv env) s- put (UI s ((binderTy x, binderTy y, env, err, from, Unify) : f))+ put (UI s ((binderTy x, binderTy y, + False,+ env, err, from, Unify) : f)) return [] -- lift $ tfail err checkCycle ns p@(x, P _ _ _) = return [p]@@ -590,9 +623,9 @@ else return [(x, bind v ns tm)] where inst [] tm = tm inst (((n, _), _) : ns) tm = inst ns (substV (P Bound n Erased) tm)- checkScope ns (x, tm) = lift $ tfail (Msg "HOLE ERROR") + checkScope ns (x, tm) = lift $ tfail (Msg "HOLE ERROR") - bind i ns tm + bind i ns tm | i < 0 = tm | otherwise = let ((x,y),ty) = ns!!i in App (Bind y (Lam ty) (bind (i-1) ns tm))@@ -639,7 +672,9 @@ -- FIXME: Depending on how overloading gets used, this may cause problems. Better -- rethink overloading properly... -- ASSUMPTION: inputs are in normal form-+--+-- Issue #1722 on the issue tracker https://github.com/idris-lang/Idris-dev/issues/1722+-- recoverable t@(App _ _) _ | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False recoverable _ t@(App _ _)@@ -658,13 +693,13 @@ recoverable p@(P _ n _) (App f a) = recoverable p f recoverable (App f a) p@(P _ _ _) = recoverable f p recoverable (App f a) (App f' a')- | f == f' = recoverable a a' + | f == f' = recoverable a a' recoverable (App f a) (App f' a') = recoverable f f' -- && recoverable a a'-recoverable f (Bind _ (Pi _ _) sc)+recoverable f (Bind _ (Pi _ _ _) sc) | (P (DCon _ _ _) _ _, _) <- unApply f = False | (P (TCon _ _) _ _, _) <- unApply f = False-recoverable (Bind _ (Pi _ _) sc) f+recoverable (Bind _ (Pi _ _ _) sc) f | (P (DCon _ _ _) _ _, _) <- unApply f = False | (P (TCon _ _) _ _, _) <- unApply f = False recoverable (Bind _ (Lam _) sc) f = recoverable sc f@@ -685,4 +720,3 @@ Just (PVar _) -> True Just (PVTy _) -> True _ -> False-
src/Idris/Coverage.hs view
@@ -56,7 +56,8 @@ = do i <- getIState let lhs_tms = map (\x -> delab' i x True True) xs -- if a placeholder was given, don't bother generating cases for it- let lhs_tms' = zipWith mergePlaceholders lhs_tms given+ let lhs_tms' = zipWith mergePlaceholders lhs_tms + (map (stripUnmatchable i) given) let lhss = map pUnApply lhs_tms' let argss = transpose lhss@@ -72,7 +73,7 @@ -- there may be more case splitting that the idris_implicits record -- suggests) let parg = case lookupCtxt n (idris_implicits i) of- (p : _) -> + (p : _) -> p ++ repeat (PExp 0 [] (sMN 0 "gcarg") Placeholder) _ -> repeat (pexp Placeholder) let tryclauses = mkClauses parg all_args@@ -93,7 +94,7 @@ -- Return whether the given clause matches none of the input clauses -- (xs)- noMatch i tm = all (\x -> case matchClause i (delab' i x True True) tm of+ noMatch i tm = all (\x -> case matchClause i (stripUnmatchable i (delab' i x True True)) tm of Right ms -> False Left miss -> True) xs @@ -122,7 +123,8 @@ -- FIXME: Just look for which one is the deepest, then generate all -- possibilities up to that depth.-+-- This and below issues for this function are tracked as Issue #1741 on the issue tracker.+-- https://github.com/idris-lang/Idris-dev/issues/1741 genAll :: IState -> [PTerm] -> [PTerm] genAll i args = case filter (/=Placeholder) $ fnub (concatMap otherPats (fnub args)) of@@ -162,10 +164,6 @@ lotsOfChars = map Ch ['a'..] lotsOfStrings = map Str (map (("some string " ++).show) [1..]) - conForm (PApp _ (PRef fc n) _) = isConName n (tt_ctxt i)- conForm (PRef fc n) = isConName n (tt_ctxt i)- conForm _ = False- nubMap f acc [] = acc nubMap f acc (x : xs) = nubMap f (fnub' acc (f x)) xs @@ -182,7 +180,7 @@ ([pimp (sUN "a") Placeholder True, pimp (sUN "P") Placeholder True] ++ [pexp t,pexp v]) o- otherPats o@(PConstant c) = return o+ otherPats o@(PConstant c) = inventConsts [o] -- return o otherPats arg = return Placeholder ops fc n xs o@@ -264,13 +262,13 @@ addIBC (IBCTotCheckErr fc msg) [Partial _] -> case lookupCtxt n (idris_callgraph i) of- [cg] -> mapM_ (checkAllCovering fc (n : done) top) + [cg] -> mapM_ (checkAllCovering fc (n : done) top) (map fst (calls cg)) _ -> return () x -> return () -- stop if total checkAllCovering _ _ _ _ = return () --- Check if, in a given group of type declarations mut_ns, +-- Check if, in a given group of type declarations mut_ns, -- the constructor cn : ty is strictly positive, -- and update the context accordingly @@ -288,12 +286,12 @@ where args t = [0..length (getArgTys t)-1] - cp (Bind n (Pi aty _) sc) = posArg aty && cp sc+ cp (Bind n (Pi _ aty _) sc) = posArg aty && cp sc cp t | (P _ n' _, args) <- unApply t,- n' `elem` mut_ns = all noRec args + n' `elem` mut_ns = all noRec args cp _ = True - posArg (Bind _ (Pi nty _) sc)+ posArg (Bind _ (Pi _ nty _) sc) | (P _ n' _, args) <- unApply nty = n' `notElem` mut_ns && all noRec args && posArg sc posArg t | (P _ n' _, args) <- unApply t,@@ -439,7 +437,7 @@ i <- getIState let opts = case lookupCtxt n (idris_flags i) of [fs] -> fs- _ -> [] + _ -> [] when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n t <- checkTotality [] fc n case t of@@ -507,11 +505,11 @@ | (P _ (UN at) _, [_, _]) <- unApply ap, at == txt "assert_total" = [] -- under a call to "Delay LazyCodata", don't do any checking of the- -- immediate call, as long as the call is guarded. + -- immediate call, as long as the call is guarded. -- Then check its arguments | (P _ (UN del) _, [_,_,arg]) <- unApply ap, Guarded <- guarded,- del == txt "Delay" + del == txt "Delay" = let (capp, args) = unApply arg in concatMap (\x -> findCalls guarded x pvs pargs) args | (P _ n _, args) <- unApply ap@@ -525,19 +523,21 @@ findCalls guarded (App f a) pvs pargs = findCalls Unguarded f pvs pargs ++ findCalls Unguarded a pvs pargs findCalls guarded (Bind n (Let t v) e) pvs pargs- = findCalls Unguarded v pvs pargs ++ findCalls guarded e (n : pvs) pargs- findCalls guarded (Bind n _ e) pvs pargs- = findCalls guarded e (n : pvs) pargs+ = findCalls Unguarded t pvs pargs +++ findCalls Unguarded v pvs pargs ++ findCalls guarded e (n : pvs) pargs+ findCalls guarded (Bind n t e) pvs pargs+ = findCalls Unguarded (binderTy t) pvs pargs +++ findCalls guarded e (n : pvs) pargs findCalls guarded (P _ f _ ) pvs pargs | not (f `elem` pvs) = [(f, [])] findCalls _ _ _ _ = [] - expandToArity n args + expandToArity n args = case lookupTy n (tt_ctxt ist) of [ty] -> expand 0 (normalise (tt_ctxt ist) [] ty) args _ -> args- where expand i (Bind n (Pi _ _) sc) (x : xs) = x : expand (i + 1) sc xs- expand i (Bind n (Pi _ _) sc) [] = Just (i, Same) : expand (i + 1) sc []+ where expand i (Bind n (Pi _ _ _) sc) (x : xs) = x : expand (i + 1) sc xs+ expand i (Bind n (Pi _ _ _) sc) [] = Just (i, Same) : expand (i + 1) sc [] expand i _ xs = xs mkChange n args pargs = [(n, expandToArity n (sizes args))]@@ -609,7 +609,7 @@ return (noPartial tot) [] -> do logLvl 5 $ "No paths for " ++ show n return Unchecked- where getArity ist n + where getArity ist n = case lookupTy n (tt_ctxt ist) of [ty] -> arity (normalise (tt_ctxt ist) [] ty) _ -> error "Can't happen: checkSizeChange.getArity"@@ -674,14 +674,14 @@ Total [] else Partial (Mutual (map (fst . fst . fst) path ++ [f])) | e `elem` map (fst . fst) path- && not (f `elem` map fst es) + && not (f `elem` map fst es) = Partial (Mutual (map (fst . fst . fst) path ++ [f])) | [Unchecked] <- lookupTotal f (tt_ctxt ist) = let argspos = case collapseNothing (zip nextargs [0..]) of [] -> [(Nothing, 0)] x -> x -- trace (show (argspos, nextargs, path)) $- pathres = + pathres = do (a, pos) <- argspos case a of Nothing -> -- don't know, but if the@@ -704,7 +704,7 @@ _ -> trace ("Shouldn't happen " ++ show e) $ return (Partial Itself) else return Unchecked in--- trace (show (desc, argspos, path, es, pathres)) $ +-- trace (show (desc, argspos, path, es, pathres)) $ collapse' Unchecked pathres | [Total a] <- lookupTotal f (tt_ctxt ist) = Total a@@ -734,4 +734,3 @@ collapse' def (d : xs) = collapse' d xs -- collapse' Unchecked [] = Total [] collapse' def [] = def-
src/Idris/DSL.hs view
@@ -18,16 +18,16 @@ t' -- addImpl i t' expandDo :: DSL -> PTerm -> PTerm-expandDo dsl (PLam n ty tm)+expandDo dsl (PLam fc n ty tm) | Just lam <- dsl_lambda dsl- = let sc = PApp (fileFC "(dsl)") lam [pexp (var dsl n tm 0)] in+ = let sc = PApp fc lam [pexp (var dsl n tm 0)] in expandDo dsl sc-expandDo dsl (PLam n ty tm) = PLam n (expandDo dsl ty) (expandDo dsl tm)-expandDo dsl (PLet n ty v tm)+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-expandDo dsl (PLet n ty v tm) = PLet n (expandDo dsl ty) (expandDo dsl v) (expandDo dsl tm)+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@@ -60,19 +60,19 @@ block b [DoExp fc tm] = tm block b [a] = PElabError (Msg "Last statement in do block must be an expression") block b (DoBind fc n tm : rest)- = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]+ = PApp fc b [pexp tm, pexp (PLam fc n Placeholder (block b rest))] block b (DoBindP fc p tm alts : rest)- = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder+ = PApp fc b [pexp tm, pexp (PLam fc (sMN 0 "bpat") Placeholder (PCase fc (PRef fc (sMN 0 "bpat")) ((p, block b rest) : alts)))] block b (DoLet fc n ty tm : rest)- = PLet n ty tm (block b rest)+ = PLet fc n ty tm (block b rest) block b (DoLetP fc p tm : rest) = PCase fc tm [(p, block b rest)] block b (DoExp fc tm : rest) = PApp fc b [pexp tm,- pexp (PLam (sMN 0 "bindx") Placeholder (block b rest))]+ pexp (PLam fc (sMN 0 "bindx") Placeholder (block b rest))] block b _ = PElabError (Msg "Invalid statement in do block") expandDo dsl (PIdiom fc e) = expandDo dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e@@ -84,14 +84,14 @@ case dsl_var dsl of Nothing -> PElabError (Msg "No 'variable' defined in dsl") Just v -> PApp fc v [pexp (mkVar fc i)]- v' i (PLam n ty sc)+ v' i (PLam fc n ty sc) | Nothing <- dsl_lambda dsl- = PLam n ty (v' i sc)- | otherwise = PLam n (v' i ty) (v' (i + 1) sc)- v' i (PLet n ty val sc)+ = PLam fc n ty (v' i sc)+ | otherwise = PLam fc n (v' i ty) (v' (i + 1) sc)+ v' i (PLet fc n ty val sc) | Nothing <- dsl_let dsl- = PLet n (v' i ty) (v' i val) (v' i sc)- | otherwise = PLet n (v' i ty) (v' i val) (v' (i + 1) sc)+ = PLet fc n (v' i ty) (v' i val) (v' i sc)+ | otherwise = PLet fc n (v' i ty) (v' i val) (v' (i + 1) sc) v' i (PPi p n ty sc) | Nothing <- dsl_pi dsl = PPi p n (v' i ty) (v' i sc)@@ -146,9 +146,9 @@ = do t' <- db' t args' <- mapM dbArg args return (PApp fc t' args')- db' (PLam n ty sc) = return (PLam n ty (debind b sc))- db' (PLet n ty v sc) = do v' <- db' v- return (PLet n ty v' (debind b sc))+ db' (PLam fc n ty sc) = return (PLam fc n ty (debind b sc))+ db' (PLet fc n ty v sc) = do v' <- db' v+ return (PLet fc n ty v' (debind b sc)) db' (PCase fc s opts) = do s' <- db' s return (PCase fc s' (map (pmap (debind b)) opts)) db' (PPair fc p l r) = do l' <- db' l@@ -170,6 +170,6 @@ bindAll [] tm = tm bindAll ((n, fc, t) : bs) tm- = PApp fc b [pexp t, pexp (PLam n Placeholder (bindAll bs tm))]+ = PApp fc b [pexp t, pexp (PLam fc n Placeholder (bindAll bs tm))]
src/Idris/DeepSeq.hs view
@@ -1,6 +1,9 @@+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+ module Idris.DeepSeq(module Idris.DeepSeq, module Idris.Core.DeepSeq) where import Idris.Core.DeepSeq+import Idris.Docstrings import Idris.Core.TT import Idris.AbsSyntaxTree @@ -48,24 +51,13 @@ rnf CT.PeriodFollowing = () rnf CT.ParenFollowing = () --- All generated by 'derive'--instance NFData IntTy where- rnf (ITFixed x1) = rnf x1 `seq` ()- rnf ITNative = ()- rnf ITBig = ()- rnf ITChar = ()- rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+instance NFData DocTerm where+ rnf Unchecked = ()+ rnf (Checked x1) = rnf x1 `seq` ()+ rnf (Example x1) = rnf x1 `seq` ()+ rnf (Failing x1) = rnf x1 `seq` () -instance NFData NativeTy where- rnf IT8 = ()- rnf IT16 = ()- rnf IT32 = ()- rnf IT64 = ()- -instance NFData ArithTy where- rnf (ATInt x1) = rnf x1 `seq` ()- rnf ATFloat = ()+-- All generated by 'derive' instance NFData SizeChange where rnf Smaller = ()@@ -73,6 +65,13 @@ rnf Bigger = () rnf Unknown = () +instance NFData FnInfo where+ rnf (FnInfo x1) = rnf x1 `seq` ()++instance NFData Codegen where+ rnf (Via x1) = rnf x1 `seq` ()+ rnf Bytecode = ()+ instance NFData CGInfo where rnf (CGInfo x1 x2 x3 x4 x5) = rnf x1 `seq`@@ -95,8 +94,8 @@ rnf _ = () instance NFData Plicity where- rnf (Imp x1 x2 x3)- = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+ rnf (Imp x1 x2 x3 x4)+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () rnf (Exp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (Constraint x1 x2)@@ -108,18 +107,24 @@ rnf Inlinable = () rnf TotalFn = () rnf PartialFn = ()+ rnf CoveringFn = () rnf Coinductive = () rnf AssertTotal = () rnf Dictionary = () rnf Implicit = ()+ rnf NoImplicit = () rnf (CExport x1) = rnf x1 `seq` ()+ rnf ErrorHandler = ()+ rnf ErrorReverse = () rnf Reflection = () rnf (Specialise x1) = rnf x1 `seq` ()+ rnf Constructor = () instance NFData DataOpt where rnf Codata = () rnf DefaultEliminator = () rnf DefaultCaseFun = ()+ rnf DataErrRev = () instance (NFData t) => NFData (PDecl' t) where rnf (PFix x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()@@ -191,10 +196,10 @@ rnf (PRef x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PInferRef x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PPatvar x1 x2) = rnf x1 `seq` rnf x2 `seq` ()- rnf (PLam x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+ rnf (PLam _ x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (PPi x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()- rnf (PLet x1 x2 x3 x4)+ rnf (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 (PApp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()@@ -210,6 +215,7 @@ rnf (PPair x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () rnf (PDPair x1 x2 x3 x4 x5) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()+ rnf (PAs x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (PAlternative x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PHidden x1) = rnf x1 `seq` () rnf PType = ()@@ -227,8 +233,11 @@ rnf (PElabError x1) = rnf x1 `seq` () rnf PImpossible = () rnf (PCoerced x1) = rnf x1 `seq` ()+ rnf (PDisamb x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PUnifyLog x1) = rnf x1 `seq` () rnf (PNoImplicits x1) = rnf x1 `seq` ()+ rnf (PQuasiquote x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (PUnquote x1) = rnf x1 `seq` () instance (NFData t) => NFData (PTactic' t) where rnf (Intro x1) = rnf x1 `seq` ()@@ -236,6 +245,7 @@ rnf (Focus x1) = rnf x1 `seq` () rnf (Refine x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (Rewrite x1) = rnf x1 `seq` ()+ rnf DoUnify = () rnf (Induction x1) = rnf x1 `seq` () rnf (CaseTac x1) = rnf x1 `seq` () rnf (Equiv x1) = rnf x1 `seq` ()@@ -245,6 +255,7 @@ rnf (Exact x1) = rnf x1 `seq` () rnf Compute = () rnf Trivial = ()+ rnf TCInstance = () rnf (ProofSearch r r1 r2 x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf Solve = ()@@ -255,13 +266,19 @@ rnf (Try x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (TSeq x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (ApplyTactic x1) = rnf x1 `seq` ()+ rnf (ByReflection x1) = rnf x1 `seq` () rnf (Reflect x1) = rnf x1 `seq` () rnf (Fill x1) = rnf x1 `seq` () rnf (GoalType x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf Qed = () rnf Abandon = ()+ rnf (TCheck x1) = rnf x1 `seq` ()+ rnf (TEval x1) = rnf x1 `seq` ()+ rnf (TDocStr x1) = x1 `seq` ()+ rnf (TSearch x1) = rnf x1 `seq` () rnf Skip = () rnf (TFail x1) = rnf x1 `seq` ()+ rnf SourceFC = () instance NFData ErrorReportPart where rnf (TermPart x1) = rnf x1 `seq` ()
src/Idris/Delaborate.hs view
@@ -56,22 +56,32 @@ Just (Just _, mi, _) -> mkMVApp n [] _ -> PRef un n de env _ (Bind n (Lam ty) sc)- = PLam n (de env [] ty) (de ((n,n):env) [] sc)- de env ((PImp { argopts = opts }):is) (Bind n (Pi ty _) sc)- = PPi (Imp opts Dynamic False) n (de env [] ty) (de ((n,n):env) is sc)- de env (PConstraint _ _ _ _:is) (Bind n (Pi ty _) sc)+ = PLam un n (de env [] ty) (de ((n,n):env) [] sc)+ de env is (Bind n (Pi (Just impl) ty _) sc)+ | tcinstance impl = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)- de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi ty _) sc)+ | otherwise+ = PPi (Imp [] Dynamic False (Just impl)) n (de env [] ty) (de ((n,n):env) is sc)+ de env ((PImp { argopts = opts }):is) (Bind n (Pi _ ty _) sc)+ = PPi (Imp opts Dynamic False Nothing) n (de env [] ty) (de ((n,n):env) is sc)+ de env (PConstraint _ _ _ _:is) (Bind n (Pi _ ty _) sc)+ = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)+ de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi _ ty _) sc) = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)- de env (plic:is) (Bind n (Pi ty _) sc)+ de env (plic:is) (Bind n (Pi _ ty _) sc) = PPi (Exp (argopts plic) Dynamic False) n (de env [] ty) (de ((n,n):env) is sc)- de env [] (Bind n (Pi ty _) sc)+ de env [] (Bind n (Pi _ ty _) sc) = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)- de env _ (Bind n (Let ty val) sc)- = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)++ de env imps (Bind n (Let ty val) sc)+ | isCaseApp sc+ , (P _ cOp _, args) <- unApply sc+ , Just caseblock <- delabCase env imps n val cOp args = caseblock+ | otherwise =+ PLet un n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc) de env _ (Bind n (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc de env _ (Bind n (Guess ty val) sc) = de ((n, sUN "[__]"):env) [] sc de env plic (Bind n bb sc) = de ((n,n):env) [] sc@@ -128,6 +138,29 @@ imp (PConstraint p l n _) arg = PConstraint p l n arg imp (PTacImplicit p l n sc _) arg = PTacImplicit p l n sc arg + isCaseApp tm | P _ n _ <- fst (unApply tm) = isCN n+ | otherwise = False+ where isCN (NS n _) = isCN n+ isCN (SN (CaseN _)) = True+ isCN _ = False++ delabCase :: [(Name, Name)] -> [PArg] -> Name -> Term -> Name -> [Term] -> Maybe PTerm+ delabCase env imps scvar scrutinee caseName caseArgs =+ do cases <- case lookupCtxt caseName (idris_patdefs ist) of+ [(cases, _)] -> return cases+ _ -> Nothing+ return $ PCase un (de env imps scrutinee)+ [ (de (env ++ map (\n -> (n, n)) vars) imps (splitArg lhs),+ de (env ++ map (\n -> (n, n)) vars) imps rhs)+ | (vars, lhs, rhs) <- cases+ ]+ where splitArg tm | (_, args) <- unApply tm = nonVar (reverse args)+ | otherwise = tm+ nonVar [] = error "Tried to delaborate empty case list"+ nonVar [x] = x+ nonVar (x@(App _ _) : _) = x+ nonVar (x@(P (DCon _ _ _) _ _) : _) = x+ nonVar (x:xs) = nonVar xs -- | How far to indent sub-errors errorIndent :: Int errorIndent = 8@@ -177,20 +210,26 @@ ++ zip nms (repeat False)) y)) <> 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 _ -> line <> line <> text "Specifically:" <> indented (pprintErr' i e) <> if (opt_errContext (idris_options i)) then showSc i sc else empty-pprintErr' i (CantConvert x y env) =+pprintErr' i (CantConvert x_in y_in env) =+ let (x_ns, y_ns, nms) = renameMNs x_in y_in+ (x, y) = addImplicitDiffs (delab i (flagUnique x_ns)) + (delab i (flagUnique y_ns)) in text "Can't convert" <>- indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env)- (delab i (flagUnique x)))) <$>+ indented (annTm x_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) env)+ x)) <$> text "with" <>- indented (annTm y (pprintTerm' i (map (\ (n, b) -> (n, False)) env)- (delab i (flagUnique y)))) <>+ indented (annTm y_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) env)+ y)) <> if (opt_errContext (idris_options i)) then line <> showSc i env else empty- where flagUnique (Bind n (Pi t k@(UType u)) sc)+ where flagUnique (Bind n (Pi i t k@(UType u)) sc) = App (P Ref (sUN (show u)) Erased)- (Bind n (Pi (flagUnique t) k) (flagUnique sc))+ (Bind n (Pi i (flagUnique t) k) (flagUnique sc)) flagUnique (App f a) = App (flagUnique f) (flagUnique a) flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc) flagUnique t = t@@ -229,6 +268,10 @@ align (cat (punctuate (comma <> space) (map (fmap (fancifyAnnots i) . annName) as))) pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n+pprintErr' i (WithFnType ty) =+ text "Can't match on a function: type is" <+> annTm ty (pprintTerm i (delab i ty))+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 UniverseError = text "Universe inconsistency" pprintErr' i (UniqueError NullType n)@@ -296,10 +339,6 @@ -- Make sure the machine invented names are shown helpfully to the user, so -- that any names which differ internally also differ visibly --- FIXME: I can't actually contrive an error to test this! Will revisit later...------ Issue #1590 in the Issue tracker.--- https://github.com/idris-lang/Idris-dev/issues/1590 renameMNs :: Term -> Term -> (Term, Term, [Name]) renameMNs x y = let ns = nub $ allTTNames x ++ allTTNames y newnames = evalState (getRenames [] ns) 1 in@@ -307,13 +346,23 @@ where getRenames :: [(Name, Name)] -> [Name] -> State Int [(Name, Name)] getRenames acc [] = return acc- getRenames acc (n@(MN i x) : xs) | UN x `elem` xs+ getRenames acc (n@(MN i x) : xs) | rpt x xs = do idx <- get put (idx + 1) let x' = sUN (str x ++ show idx) getRenames ((n, x') : acc) xs+ getRenames acc (n@(UN x) : xs) | rpt x xs + = do idx <- get+ put (idx + 1)+ let x' = sUN (str x ++ show idx)+ getRenames ((n, x') : acc) xs getRenames acc (x : xs) = getRenames acc xs + rpt x [] = False+ rpt x (UN y : xs) | x == y = True+ rpt x (MN i y : xs) | x == y = True+ rpt x (_ : xs) = rpt x xs+ rename :: [(Name, Name)] -> Term -> Term rename ns (P nt x t) | Just x' <- lookup x ns = P nt x' t rename ns (App f a) = App (rename ns f) (rename ns a)@@ -346,10 +395,11 @@ getTm = b' } : bs') else (a { getTm = a' } : as', b { getTm = b' } : bs')- addI (PLam n a b) (PLam n' c d)+ addShows xs ys = (xs, ys)+ addI (PLam fc n a b) (PLam fc' n' c d) = let (a', c') = addI a c (b', d') = addI b d in- (PLam n a' b', PLam n' c' d')+ (PLam fc n a' b', PLam fc' n' c' d') addI (PPi p n a b) (PPi p' n' c d) = let (a', c') = addI a c (b', d') = addI b d in@@ -399,7 +449,7 @@ and (zipWith expLike (getExps as) (getExps as')) expLike (PPi _ n s t) (PPi _ n' s' t') = n == n' && expLike s s' && expLike t t'- expLike (PLam n s t) (PLam n' s' t')+ expLike (PLam _ n s t) (PLam _ n' s' t') = n == n' && expLike s s' && expLike t t' expLike (PPair _ _ x y) (PPair _ _ x' y') = expLike x x' && expLike y y' expLike (PDPair _ _ x _ y) (PDPair _ _ x' _ y') = expLike x x' && expLike y y'@@ -479,3 +529,5 @@ showbasic (MN _ s) = str s showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n showbasic (SN s) = show s+showbasic n = show n+
src/Idris/Docs.hs view
@@ -31,6 +31,8 @@ [(Name, Maybe (Docstring DocTerm))] -- parameters and their docstrings [PTerm] -- instances [PTerm] -- superclasses+ | ModDoc [String] -- Module name+ (Docstring DocTerm) showDoc ist d | nullDocstring d = empty@@ -138,7 +140,19 @@ 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 (ModDoc mod docs)+ = nest 4 $ text "Module" <+> text (concat (intersperse "." mod)) <> colon <$>+ renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) docs++-- | Given a fully-qualified, disambiguated name, construct the+-- documentation object for it getDocs :: Name -> Idris Docs+getDocs n@(NS n' ns) | n' == modDocName+ = do i <- getIState+ case lookupCtxtExact n (idris_moduledocs i) of+ Just doc -> return $ ModDoc (reverse (map T.unpack ns)) 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 = do i <- getIState case lookupCtxt n (idris_classes i) of
src/Idris/Docstrings.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-}-{-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} -- | Wrapper around Markdown library module Idris.Docstrings (
+ src/Idris/Elab/AsPat.hs view
@@ -0,0 +1,48 @@+module Idris.Elab.AsPat(desugarAs) where++import Idris.Core.TT+import Idris.AbsSyntax++import Control.Applicative+import Control.Monad.State.Strict++import Data.Generics.Uniplate.Data (transformM)++-- | Desugar by changing x@y on lhs to let x = y in ... or rhs+desugarAs :: PTerm -> PTerm -> (PTerm, PTerm)+desugarAs lhs rhs+ = let (lhs', pats) = runState (collectAs (replaceUnderscore lhs)) [] in+ (lhs', bindPats pats rhs)+ where+ bindPats :: [(Name, FC, PTerm)] -> PTerm -> PTerm+ bindPats [] rhs = rhs+ bindPats ((n, fc, tm) : ps) rhs+ = PLet fc n Placeholder tm (bindPats ps rhs)++collectAs :: PTerm -> State [(Name, FC, PTerm)] PTerm+collectAs (PAs fc n tm) = do tm' <- collectAs tm+ pats <- get+ put (pats ++ [(n, fc, tm')])+ return tm'+collectAs (PApp fc t as)+ = do as_tm <- mapM collectAs (map getTm as)+ let as' = zipWith (\a tm -> a { getTm = tm }) as as_tm+ return (PApp fc t as') -- only valid on args+collectAs x = return x++-- | Replace _-patterns under @-patterns with fresh names that can be+-- used on the RHS+replaceUnderscore :: PTerm -> PTerm+replaceUnderscore tm = evalState (transformM (underAs replaceUnderscore') tm) 0+ where+ underAs :: (PTerm -> State Int PTerm) -> PTerm -> State Int PTerm+ underAs f (PAs fc n tm) = PAs fc n <$> transformM f tm+ underAs f x = return x++ fresh :: State Int Name+ fresh = modify (+1) >> flip sMN "underscorePatVar" <$> get+++ replaceUnderscore' :: PTerm -> State Int PTerm+ replaceUnderscore' Placeholder = PRef emptyFC <$> fresh+ replaceUnderscore' tm = return tm
src/Idris/Elab/Class.hs view
@@ -53,7 +53,7 @@ data MArgTy = IA | EA | CA deriving Show elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->- FC -> [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 = do let cn = SN (InstanceCtorN tn) -- sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)@@ -115,7 +115,7 @@ $ tfail (At fc (Msg $ "Default superclass instances can't have constraints.")) i <- getIState let t = PApp fc (PRef fc n) (map pexp ps)- let isConstrained = any (== t) constraints+ let isConstrained = any (== t) (map snd constraints) when (not isConstrained) . tclift $ tfail (At fc (Msg $ "Default instances must be for a superclass constraint on the containing class.")) return ()@@ -124,8 +124,8 @@ impbind [] x = x impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x) - conbind :: [PTerm] -> PTerm -> PTerm - conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)+ 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@@ -133,7 +133,8 @@ = do t' <- implicit' info syn allmeths n t logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t' return ( (n, (toExp (map fst ps) Exp t')),- (n, (doc, o, (toExp (map fst ps) Imp t'))),+ (n, (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" @@ -160,15 +161,15 @@ clause _ = False -- Generate a function for chasing a dictionary constraint- cfun :: Name -> PTerm -> SyntaxInfo -> [a] -> PTerm -> Idris [PDecl' PTerm]- cfun cn c syn all con+ cfun :: Name -> PTerm -> SyntaxInfo -> [a] -> (Name, PTerm) -> Idris [PDecl' PTerm]+ cfun cn c syn all (cnm, con) = do let cfn = sUN ('@':'@':show cn ++ "#" ++ show con) -- SN (ParentN cn (show con)) let mnames = take (length all) $ map (\x -> sMN x "meth") [0..] let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames) let lhs = PApp fc (PRef fc cfn) [pconst capp] let rhs = PResolveTC (fileFC "HACK")- let ty = PPi constraint (sMN 0 "pc") c con+ let ty = PPi constraint cnm c con iLOG (showTmImpls ty) iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs) i <- getIState@@ -200,7 +201,7 @@ 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 (Imp _ _ _ _) n ty sc) = IA : getMArgs sc getMArgs (PPi (Exp _ _ _) n ty sc) = EA : getMArgs sc getMArgs (PPi (Constraint _ _) n ty sc) = CA : getMArgs sc getMArgs _ = []@@ -218,13 +219,13 @@ rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns rhsArgs [] _ = [] - insertConstraint c (PPi p@(Imp _ _ _) n ty sc)+ insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc) = PPi p n ty (insertConstraint c sc) insertConstraint c sc = PPi (constraint { pstatic = Static }) (sMN 0 "class") c sc -- make arguments explicit and don't bind class parameters- toExp ns e (PPi (Imp l s p) n ty sc)+ toExp ns e (PPi (Imp l s p _) n ty sc) | n `elem` ns = toExp ns e sc | otherwise = PPi (e l s p) n ty (toExp ns e sc) toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)
src/Idris/Elab/Clause.hs view
@@ -19,6 +19,7 @@ import Idris.Output (iputStrLn, pshow, iWarn, iRenderResult) import IRTS.Lang +import Idris.Elab.AsPat import Idris.Elab.Type import Idris.Elab.Transform import Idris.Elab.Utils@@ -40,6 +41,7 @@ import Control.DeepSeq import Control.Monad import Control.Monad.State.Strict as State+import qualified Control.Monad.State.Lazy as LState import Data.List import Data.Maybe import Debug.Trace@@ -56,8 +58,10 @@ -- | Elaborate a collection of left-hand and right-hand pairs - that is, a -- top-level definition. elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()-elabClauses info fc opts n_in cs = let n = liftname info n_in in- do ctxt <- getContext+elabClauses info' fc opts n_in cs =+ do let n = liftname info n_in+ info = info' { elabFC = Just fc }+ ctxt <- getContext ist <- getIState optimise <- getOptimise let petrans = PETransform `elem` optimise@@ -155,7 +159,7 @@ erInfo <- getErasureInfo <$> getIState tree@(CaseDef scargs sc _) <- tclift $- simpleCase tcase False reflect CompileTime fc inacc atys pdef erInfo+ simpleCase tcase (UnmatchedCase "Error") reflect CompileTime fc inacc atys pdef erInfo cov <- coverage pmissing <- if cov && not (hasDefault cs)@@ -202,8 +206,14 @@ ":warning - Unreachable case: " ++ show (delab ist x)) xs let knowncovering = (pcover && cov) || AssertTotal `elem` opts+ let defaultcase = if knowncovering + then STerm Erased+ else UnmatchedCase $ "*** " ++ + show fc ++ + ":unmatched case in " ++ show n ++ + " ***" - tree' <- tclift $ simpleCase tcase knowncovering reflect+ tree' <- tclift $ simpleCase tcase defaultcase reflect RunTime fc inacc atys pdef' erInfo logLvl 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree logLvl 3 $ "Optimised: " ++ show tree'@@ -215,7 +225,7 @@ let caseInfo = CaseInfo (inlinable opts) (dictionary opts) case lookupTy n ctxt of [ty] -> do updateContext (addCasedef n erInfo caseInfo- tcase knowncovering+ tcase defaultcase reflect (AssertTotal `elem` opts) atys@@ -442,7 +452,7 @@ i <- getIState let lhs = addImplPat i lhs_in -- if the LHS type checks, it is possible- case elaborate ctxt (sMN 0 "patLHS") infP []+ 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')@@ -494,6 +504,7 @@ ntRec x y | Ref <- x = True | Ref <- y = True+ | (Bound, Bound) <- (x, y) = True | otherwise = False -- name is different, unrecoverable propagateParams :: IState -> [Name] -> Type -> PTerm -> PTerm@@ -541,9 +552,11 @@ (Msg $ show lhs_in ++ " is a valid case")) False -> do ptm <- mkPatTm lhs_in return (Left ptm, lhs)-elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)+elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as whereblock) = do let tcgen = Dictionary `elem` opts+ push_estack fname ctxt <- getContext+ let (lhs_in, rhs_in) = desugarAs lhs_in_as rhs_in_as -- Build the LHS as an "Infer", and pull out its type and -- pattern bindings@@ -557,21 +570,23 @@ [t] -> t _ -> [] let params = getParamsInType i [] fn_is fn_ty- let lhs = mkLHSapp $ stripUnmatchable i $- propagateParams i params fn_ty (addImplPat i (stripLinear i lhs_in))+ let lhs = mkLHSapp $ stripLinear i $ stripUnmatchable i $+ propagateParams i params fn_ty (addImplPat i lhs_in)+-- let lhs = mkLHSapp $ +-- propagateParams i params fn_ty (addImplPat i lhs_in) logLvl 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs) 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 []+ 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)) - when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)+ when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs) let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs'@@ -618,7 +633,7 @@ let uniqargs = findUnique (tt_ctxt ist) [] lhs_tm let newargs = filter (\(n,_) -> n `notElem` uniqargs) newargs_all - let winfo = pinfo info newargs defs windex+ let winfo = (pinfo info newargs defs windex) { elabFC = Just fc } let wb = map (mkStatic static_names) $ map (expandParamsD False ist decorate newargs defs) whereblock @@ -638,7 +653,7 @@ ctxt <- getContext -- new context with where block added logLvl 5 "STARTING CHECK" ((rhs', defer, is, probs), _) <-- tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty []+ tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty initEState (do pbinds ist lhs_tm mapM_ setinj (nub (params ++ inj)) setNextName@@ -648,13 +663,13 @@ (erun fc $ psolve lhs_tm) hs <- get_holes aux <- getAux- mapM_ (elabCaseHole aux) hs+ mapM_ (elabCaseHole (case_decls aux)) hs tt <- get_term let (tm, ds) = runState (collectDeferred (Just fname) tt) [] probs <- get_probs return (tm, ds, is, probs)) - when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)+ when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs) logLvl 5 "DONE CHECK" logLvl 2 $ "---> " ++ show rhs'@@ -682,8 +697,12 @@ then recheckC_borrowing True borrowed fc [] rhs' else return (rhs', clhsty) logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty- case converts ctxt [] clhsty crhsty of- OK _ -> return ()+ ctxt <- getContext+ let constv = next_tvar ctxt+ case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of+ OK (_, cs) -> do addConstraints fc cs + logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs+ return () Error e -> ierror (At fc (CantUnify False clhsty crhsty e [] 0)) i <- getIState checkInferred fc (delab' i crhs True True) rhs@@ -701,6 +720,7 @@ when (rev || ErrorReverse `elem` opts) $ do addIBC (IBCErrRev (crhs, clhs)) addErrRev (crhs, clhs)+ pop_estack return $ (Right (clhs, crhs), lhs) where pinfo :: ElabInfo -> [(Name, PTerm)] -> [Name] -> Int -> ElabInfo@@ -789,10 +809,10 @@ [t] -> t _ -> [] let params = getParamsInType i [] fn_is fn_ty- let lhs = propagateParams i params fn_ty (addImplPat i (stripLinear i lhs_in))+ let lhs = stripLinear i $ stripUnmatchable i $ propagateParams i params fn_ty (addImplPat i lhs_in) logLvl 2 ("LHS: " ++ show lhs) ((lhs', dlhs, []), _) <-- tclift $ elaborate ctxt (sMN 0 "patLHS") infP []+ 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))) ) let lhs_tm = orderPats (getInferTerm lhs')@@ -808,7 +828,7 @@ -- Elaborate wval in this context ((wval', defer, is), _) <- tclift $ elaborate ctxt (sMN 0 "withRHS")- (bindTyArgs PVTy bargs infP) []+ (bindTyArgs PVTy bargs infP) initEState (do pbinds i lhs_tm setNextName -- TODO: may want where here - see winfo abpve@@ -826,6 +846,13 @@ let cwvaltyN = explicitNames (normalise ctxt [] cwvalty) let cwvalN = explicitNames (normalise ctxt [] cwval) logLvl 3 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty)+ -- We're going to assume the with type is not a function shortly,+ -- so report an error if it is (you can't match on a function anyway+ -- so this doesn't lose anything)+ case getArgTys cwvaltyN of+ [] -> return ()+ (_:_) -> ierror $ At fc (WithFnType cwvalty) + let pvars = map fst (getPBtys cwvalty) -- we need the unelaborated term to get the names it depends on -- rather than a de Bruijn index.@@ -840,7 +867,7 @@ let wargval = getRetTy cwvalN let wargtype = getRetTy cwvaltyN logLvl 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)- let wtype = bindTyArgs (flip Pi (TType (UVar 0))) (bargs_pre +++ 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)@@ -881,7 +908,7 @@ ctxt <- getContext -- New context with block added i <- getIState ((rhs', defer, is), _) <-- tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty []+ 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)@@ -896,7 +923,7 @@ (crhs, crhsty) <- recheckC fc [] rhs' return $ (Right (clhs, crhs), lhs) where- getImps (Bind n (Pi _ _) t) = pexp Placeholder : getImps t+ getImps (Bind n (Pi _ _ _) t) = pexp Placeholder : getImps t getImps _ = [] mkAuxC wname lhs ns ns' (PClauses fc o n cs)
src/Idris/Elab/Data.hs view
@@ -66,9 +66,10 @@ undef <- isUndefined fc n (cty, _, t, inacc) <- buildType info syn fc [] n t_in -- if n is defined already, make sure it is just a type declaration- -- with the same type we've just elaborated+ -- with the same type we've just elaborated, and no constructors+ -- yet i <- getIState- checkDefinedAs fc n cty (tt_ctxt i)+ checkDefinedAs fc n cty i -- temporary, to check cons when undef $ updateContext (addTyDecl n (TCon 0 0) cty) let cnameinfo = cinfo info (map cname dcons)@@ -124,14 +125,18 @@ [oi] -> putIState ist{ idris_optimisation = addDef n oi{ detaggable = True } opt } _ -> putIState ist{ idris_optimisation = addDef n (Optimise [] True) opt } - checkDefinedAs fc n t ctxt- = case lookupDef n ctxt of+ checkDefinedAs fc n t i+ = let defined = tclift $ tfail (At fc (AlreadyDefined n))+ ctxt = tt_ctxt i in+ case lookupDef n ctxt of [] -> return () [TyDecl _ ty] -> case converts ctxt [] t ty of- OK () -> return ()- _ -> tclift $ tfail (At fc (AlreadyDefined n))- _ -> tclift $ tfail (At fc (AlreadyDefined n))+ OK () -> case lookupCtxtExact n (idris_datatypes i) of+ Nothing -> return ()+ _ -> defined+ _ -> defined+ _ -> defined -- parameters are names which are unchanged across the structure, -- which appear exactly once in the return type of a constructor @@ -172,7 +177,7 @@ getDataApp f@(App _ _) | (P _ d _, args) <- unApply f = if (d == n) then [mParam args args] else []- getDataApp (Bind n (Pi t _) sc)+ getDataApp (Bind n (Pi _ t _) sc) = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc) getDataApp _ = [] @@ -222,6 +227,10 @@ logLvl 5 $ "Inaccessible args: " ++ show inacc logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty' + -- Add to the context (this is temporary, so that later constructors+ -- can be indexed by it)+ updateContext (addTyDecl n (DCon 0 0 False) cty) + addIBC (IBCDef n) checkDocs fc argDocs t doc' <- elabDocTerms info doc@@ -265,10 +274,10 @@ = tclift $ tfail (At fc (UniqueKindError NullType n)) checkUniqueKind (UType UniqueType) (UType UniqueType) = return () checkUniqueKind (UType UniqueType) (UType AllTypes) = return ()- checkUniqueKind (UType UniqueType) (TType _)+ checkUniqueKind (UType UniqueType) _ = tclift $ tfail (At fc (UniqueKindError UniqueType n)) checkUniqueKind (UType AllTypes) _ = return ()- checkUniqueKind (TType _) _ = return ()+ checkUniqueKind _ _ = return () type EliminatorState = StateT (Map.Map String Int) Idris
src/Idris/Elab/Instance.hs view
@@ -52,7 +52,7 @@ elabInstance :: ElabInfo -> SyntaxInfo -> ElabWhat -> -- phase- FC -> [PTerm] -> -- constraints+ FC -> [(Name, PTerm)] -> -- constraints Name -> -- the class [PTerm] -> -- class parameters (i.e. instance) PTerm -> -- full instance type@@ -66,7 +66,7 @@ cs -> tclift $ tfail $ At fc (CantResolveAlts (map fst cs)) let constraint = PApp fc (PRef fc n) (map pexp ps)- let iname = mkiname n ps expn+ 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@@ -140,9 +140,11 @@ [PConstant (AType (ATInt ITNative))] -> True _ -> False - mkiname n' ps' expn' =+ mkiname n' ns ps' expn' = case expn' of- Nothing -> SN (sInstanceN n' (map show ps'))+ Nothing -> case ns of+ Nothing -> SN (sInstanceN n' (map show ps'))+ Just m -> sNS (SN (sInstanceN n' (map show ps'))) m Just nm -> nm substInstance ips pnames (PInstance syn _ cs n ps t expn ds)@@ -150,7 +152,7 @@ isOverlapping i (PInstance syn _ _ n ps t expn _) = case lookupCtxtName n (idris_classes i) of- [(n, ci)] -> let iname = (mkiname n ps expn) in+ [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in case lookupTy iname (tt_ctxt i) of [] -> elabFindOverlapping i ci iname syn t (_:_) -> return True@@ -166,7 +168,7 @@ let ty = addImpl i ty' ctxt <- getContext ((tyT, _, _), _) <-- tclift $ elaborate ctxt iname (TType (UVal 0)) []+ tclift $ elaborate ctxt iname (TType (UVal 0)) initEState (errAt "type of " iname (erun fc (build i info ERHS [] iname ty))) ctxt <- getContext (cty, _) <- recheckC fc [] tyT@@ -193,11 +195,11 @@ mkMethApp (n, _, _, ty) = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty)) lamBind i (PPi (Constraint _ _) _ _ sc) sc'- = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')+ = PLam fc (sMN i "meth") Placeholder (lamBind (i+1) sc sc') lamBind i (PPi _ n ty sc) sc'- = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')+ = PLam fc (sMN i "meth") Placeholder (lamBind (i+1) sc sc') lamBind i _ sc = sc- methArgs i (PPi (Imp _ _ _) n ty sc)+ methArgs i (PPi (Imp _ _ _ _) n ty sc) = PImp 0 True [] n (PRef fc (sMN i "meth")) : methArgs (i+1) sc methArgs i (PPi (Exp _ _ _) n ty sc) = PExp 0 [] (sMN 0 "marg") (PRef fc (sMN i "meth")) : methArgs (i+1) sc@@ -223,11 +225,12 @@ mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t - conbind (ty : ns) x = PPi (constraint) -- { pstatic = Dynamic }) - (sMN 0 "class") ty (conbind ns x)+ conbind :: [(Name, PTerm)] -> PTerm -> PTerm+ conbind ((c,ty) : ns) x = PPi constraint c ty (conbind ns x) conbind [] x = x - coninsert cs (PPi p@(Imp _ _ _) n t sc) = PPi p n t (coninsert cs sc)+ coninsert :: [(Name, PTerm)] -> PTerm -> PTerm+ coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc) coninsert cs sc = conbind cs sc insertDefaults :: IState -> Name ->
src/Idris/Elab/Record.hs view
@@ -130,13 +130,13 @@ -- ++ "\n" ++ pshow i v putIState i) - getBoundImpls (PPi (Imp _ _ _) n ty sc) = (n, ty) : getBoundImpls sc+ getBoundImpls (PPi (Imp _ _ _ _) n ty sc) = (n, ty) : getBoundImpls sc getBoundImpls _ = [] - getImplB k (PPi (Imp l s _) n Placeholder sc)+ getImplB k (PPi (Imp l s _ _) n Placeholder sc) = getImplB k sc- getImplB k (PPi (Imp l s p) n ty sc)- = getImplB (\x -> k (PPi (Imp l s p) n ty x)) sc+ getImplB k (PPi (Imp l s p fa) n ty sc)+ = getImplB (\x -> k (PPi (Imp l s p fa) n ty x)) sc getImplB k (PPi _ n ty sc) = getImplB k sc getImplB k _ = k
src/Idris/Elab/Transform.hs view
@@ -54,26 +54,30 @@ i <- getIState let lhs = addImplPat i lhs_in ((lhs', dlhs, []), _) <-- tclift $ elaborate ctxt (sMN 0 "transLHS") infP []+ tclift $ elaborate ctxt (sMN 0 "transLHS") infP initEState (erun fc (buildTC i info ELHS [] (sUN "transform") (infTerm lhs))) let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs' let newargs = pvars i lhs_tm - (clhs_tm, clhs_ty) <- recheckC fc [] lhs_tm+ (clhs_tm_in, clhs_ty) <- recheckC fc [] 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), _) <-- tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty []+ tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty initEState (do pbinds i lhs_tm setNextName erun fc (build i info ERHS [] (sUN "transform") rhs) erun fc $ psolve lhs_tm tt <- get_term return (runState (collectDeferred Nothing tt) []))- (crhs_tm, crhs_ty) <- recheckC fc [] rhs'+ (crhs_tm_in, crhs_ty) <- recheckC fc [] 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 ()@@ -93,6 +97,14 @@ where depat (Bind n (PVar t) sc) = depat (instantiate (P Bound n t) sc) depat x = x++ renamepats (n' : ns) (Bind n (PVar t) sc)+ = Bind n' (PVar t) (renamepats ns sc) -- all Vs+ renamepats _ sc = sc++ -- names for transformation variables. Need to ensure these don't clash+ -- with any other names when applying rules, so rename here.+ pnames = map (\i -> sMN i ("tvar" ++ show i)) [0..] elabTransform info fc safe lhs_in rhs_in = ierror (At fc (Msg "Invalid transformation rule (must be function application)"))
src/Idris/Elab/Type.hs view
@@ -66,7 +66,7 @@ logLvl 3 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty ((tyT', defer, is), log) <-- tclift $ elaborate ctxt n (TType (UVal 0)) []+ tclift $ elaborate ctxt n (TType (UVal 0)) initEState (errAt "type of " n (erun fc (build i info ETyDecl [] n ty))) let tyT = patToImp tyT'@@ -104,11 +104,11 @@ return (cty, ckind, ty, inacc) where- patToImp (Bind n (PVar t) sc) = Bind n (Pi t (TType (UVar 0))) (patToImp sc)+ patToImp (Bind n (PVar t) sc) = Bind n (Pi Nothing t (TType (UVar 0))) (patToImp sc) patToImp (Bind n b sc) = Bind n b (patToImp sc) patToImp t = t - param_pos i ns (Bind n (Pi t _) sc) + param_pos i ns (Bind n (Pi _ t _) sc) | n `elem` ns = i : param_pos (i + 1) ns sc | otherwise = param_pos (i + 1) ns sc param_pos i ns t = []@@ -196,7 +196,7 @@ lst = txt "List" errrep = txt "ErrorReportPart" - tyIsHandler (Bind _ (Pi (P _ (NS (UN e) ns1) _) _)+ tyIsHandler (Bind _ (Pi _ (P _ (NS (UN e) ns1) _) _) (App (P _ (NS (UN m) ns2) _) (App (P _ (NS (UN l) ns3) _) (P _ (NS (UN r) ns4) _))))
src/Idris/Elab/Utils.hs view
@@ -30,6 +30,7 @@ (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs ctxt env (forget t) t of Error e -> tfail (At fc e) OK x -> return x+ logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs addConstraints fc cs return (tm, ty) @@ -48,14 +49,14 @@ -- 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)+inaccessibleImps i (Bind n (Pi _ t _) sc) (inacc : ins) | inacc = (i, n) : inaccessibleImps (i + 1) sc ins | otherwise = inaccessibleImps (i + 1) sc ins inaccessibleImps _ _ _ = [] -- Get the list of (index, name) of inaccessible arguments from the type. inaccessibleArgs :: Int -> PTerm -> [(Int, Name)]-inaccessibleArgs i (PPi (Imp _ _ _) n Placeholder t)+inaccessibleArgs i (PPi (Imp _ _ _ _) n Placeholder t) = (i,n) : inaccessibleArgs (i+1) t -- unbound implicit inaccessibleArgs i (PPi plicity n ty t) | InaccessibleArg `elem` pargopts plicity@@ -154,10 +155,13 @@ pvars ist (Bind n (PVar t) sc) = (n, delab ist t) : pvars ist sc pvars ist _ = [] -getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi t _) sc)+getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi _ t _) sc) = nub $ getFixedInType i env [] t ++ getFixedInType i (n : env) is (instantiate (P Bound n t) sc)-getFixedInType i env (_ : is) (Bind n (Pi t _) sc)+ ++ case t of+ P _ n _ -> if n `elem` env then [n] else []+ _ -> []+getFixedInType i env (_ : is) (Bind n (Pi _ t _) sc) = getFixedInType i (n : env) is (instantiate (P Bound n t) sc) getFixedInType i env is tm@(App f a) | (P _ tn _, args) <- unApply tm@@ -171,7 +175,7 @@ getFixedInType i env is a getFixedInType i _ _ _ = [] -getFlexInType i env ps (Bind n (Pi t _) sc)+getFlexInType i env ps (Bind n (Pi _ t _) sc) = nub $ (if (not (n `elem` ps)) then getFlexInType i env ps t else []) ++ getFlexInType i (n : env) ps (instantiate (P Bound n t) sc) getFlexInType i env ps tm@(App f a)@@ -229,11 +233,11 @@ use n = do ns <- get; put (n : ns) - getUniqB env us (Let t v) = do getUniq env us t; getUniq env us v- getUniqB env us (Guess t v) = do getUniq env us t; getUniq env us v- getUniqB env us (Pi t v) = do getUniq env us t; getUniq env us v- getUniqB env us (NLet t v) = do getUniq env us t; getUniq env us v- getUniqB env us b = getUniq env us (binderTy b)+ getUniqB env us (Let t v) = getUniq env us v+ getUniqB env us (Guess t v) = getUniq env us v+-- getUniqB env us (Pi t v) = do getUniq env us t; getUniq env us v+ getUniqB env us (NLet t v) = getUniq env us v+ getUniqB env us b = return () -- getUniq env us (binderTy b) -- In a functional application, return the names which are used -- directly in a static position@@ -252,7 +256,7 @@ getStaticNames _ _ = [] getStatics :: [Name] -> Term -> [Bool]-getStatics ns (Bind n (Pi _ _) t)+getStatics ns (Bind n (Pi _ _ _) t) | n `elem` ns = True : getStatics ns t | otherwise = False : getStatics ns t getStatics _ _ = []
src/Idris/Elab/Value.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE PatternGuards #-}-{-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms) where import Idris.AbsSyntax@@ -64,7 +64,7 @@ -- * elaboration as a function a -> b ((tm', defer, is), _) <-- tclift (elaborate ctxt (sMN 0 "val") infP []+ tclift (elaborate ctxt (sMN 0 "val") infP initEState (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm))) let vtm = orderPats (getInferTerm tm')
src/Idris/ElabDecls.hs view
@@ -62,7 +62,7 @@ -- Top level elaborator info, supporting recursive elaboration recinfo :: ElabInfo-recinfo = EInfo [] emptyContext id Nothing elabDecl'+recinfo = EInfo [] emptyContext id Nothing Nothing elabDecl' -- | Return the elaborated term which calls 'main' elabMain :: Idris Term@@ -103,9 +103,9 @@ p_believeMe [_,_,x] = Just x p_believeMe _ = Nothing- believeTy = Bind (sUN "a") (Pi (TType (UVar (-2))) (TType (UVar (-1))))- (Bind (sUN "b") (Pi (TType (UVar (-2))) (TType (UVar (-1))))- (Bind (sUN "x") (Pi (V 1) (TType (UVar (-1)))) (V 1)))+ believeTy = Bind (sUN "a") (Pi Nothing (TType (UVar (-2))) (TType (UVar (-1))))+ (Bind (sUN "b") (Pi Nothing (TType (UVar (-2))) (TType (UVar (-1))))+ (Bind (sUN "x") (Pi Nothing (V 1) (TType (UVar (-1)))) (V 1))) elabBelieveMe = do let prim__believe_me = sUN "prim__believe_me" updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)@@ -126,10 +126,10 @@ vnNothing = VP (DCon 0 1 False) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased vnRefl = VP (DCon 0 2 False) eqCon VErased - synEqTy = Bind (sUN "a") (Pi (TType (UVar (-3))) (TType (UVar (-2))))- (Bind (sUN "b") (Pi (TType (UVar (-3))) (TType (UVar (-2))))- (Bind (sUN "x") (Pi (V 1) (TType (UVar (-2))))- (Bind (sUN "y") (Pi (V 1) (TType (UVar (-2))))+ synEqTy = Bind (sUN "a") (Pi Nothing (TType (UVar (-3))) (TType (UVar (-2))))+ (Bind (sUN "b") (Pi Nothing (TType (UVar (-3))) (TType (UVar (-2))))+ (Bind (sUN "x") (Pi Nothing (V 1) (TType (UVar (-2))))+ (Bind (sUN "y") (Pi Nothing (V 1) (TType (UVar (-2)))) (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased) [V 3, V 2, V 1, V 0]])))) elabSynEq
src/Idris/ElabQuasiquote.hs view
@@ -70,19 +70,19 @@ extractUnquotes :: Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)])-extractUnquotes n (PLam name ty body)+extractUnquotes n (PLam fc name ty body) = do (ty', ex1) <- extractUnquotes n ty (body', ex2) <- extractUnquotes n body- return (PLam name ty' body', ex1 ++ ex2)+ return (PLam fc name ty' body', ex1 ++ ex2) extractUnquotes n (PPi plicity name ty body) = do (ty', ex1) <- extractUnquotes n ty (body', ex2) <- extractUnquotes n body return (PPi plicity name ty' body', ex1 ++ ex2)-extractUnquotes n (PLet name ty val body)+extractUnquotes n (PLet fc name ty val body) = do (ty', ex1) <- extractUnquotes n ty (val', ex2) <- extractUnquotes n val (body', ex3) <- extractUnquotes n body- return (PLet name ty' val' body', ex1 ++ ex2 ++ ex3)+ return (PLet fc name ty' val' body', ex1 ++ ex2 ++ ex3) extractUnquotes n (PTyped tm ty) = do (tm', ex1) <- extractUnquotes n tm (ty', ex2) <- extractUnquotes n ty
src/Idris/ElabTerm.hs view
@@ -52,8 +52,11 @@ let inf = case lookupCtxt fn (idris_tyinfodata ist) of [TIPartial] -> True _ -> False- ivs <- get_instances++ when (not pattern) $ solveAutos ist fn True+ hs <- get_holes+ ivs <- get_instances ptm <- get_term -- Resolve remaining type classes. Two passes - first to get the -- default Num instances, second to clean up the rest@@ -84,14 +87,14 @@ probs <- get_probs case probs of [] -> return ()- ((_,_,_,e,_,_):es) -> traceWhen u ("Final problems:\n" ++ show probs) $- if inf then return ()- else lift (Error e)+ ((_,_,_,_,e,_,_):es) -> traceWhen u ("Final problems:\n" ++ show probs) $+ if inf then return ()+ else lift (Error e) when tydecl (do update_term orderPats mkPat) -- update_term liftPats)- is <- getAux+ EState is _ <- getAux tt <- get_term let (tm, ds) = runState (collectDeferred (Just fn) tt) [] log <- getLog@@ -125,9 +128,14 @@ tm <- get_term case probs of [] -> return ()- ((_,_,_,e,_,_):es) -> if inf then return ()- else lift (Error e)- is <- getAux+ ((_,_,_,_,e,_,_):es) -> if inf then return ()+ else lift (Error e)+ dots <- get_dotterm+ -- 'dots' are the PHidden things which have not been solved by+ -- unification+ when (not (null dots)) $+ lift (Error (CantMatch (getInferTerm tm)))+ EState is _ <- getAux tt <- get_term let (tm, ds) = runState (collectDeferred (Just fn) tt) [] log <- getLog@@ -135,6 +143,45 @@ else return (tm, ds, is) where pattern = emode == ELHS +-- return whether arguments of the given constructor name can be +-- matched on. If they're polymorphic, no, unless the type has beed made+-- concrete by the time we get around to elaborating the argument.+getUnmatchable :: Context -> Name -> [Bool]+getUnmatchable ctxt n | isDConName n ctxt && n /= inferCon+ = case lookupTyExact n ctxt of+ Nothing -> []+ Just ty -> checkArgs [] [] ty+ where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool]+ checkArgs env ns (Bind n (Pi _ t _) sc) + = let env' = case t of+ TType _ -> n : env+ _ -> env in+ checkArgs env' (intersect env (refsIn t) : ns) + (instantiate (P Bound n t) sc)+ checkArgs env ns t+ = map (not . null) (reverse ns)++getUnmatchable ctxt n = []++data ElabCtxt = ElabCtxt { e_inarg :: Bool,+ e_guarded :: Bool, + e_intype :: Bool,+ e_qq :: Bool,+ e_nomatching :: Bool -- ^ can't pattern match+ }++initElabCtxt = ElabCtxt False False False False False++goal_polymorphic :: ElabD Bool+goal_polymorphic =+ do ty <- goal+ case ty of+ P _ n _ -> do env <- get_env+ case lookup n env of+ Nothing -> return False+ _ -> return True+ _ -> return False+ -- Returns the set of declarations we need to add to complete the definition -- (most likely case blocks to elaborate) @@ -144,7 +191,10 @@ = do let loglvl = opt_logLevel (idris_options ist) when (loglvl > 5) $ unifyLog True compute -- expand type synonyms, etc- elabE (False, False, False, False) tm -- (in argument, guarded, in type, in qquote)+ let fc = maybe "(unknown)"+ elabE initElabCtxt (elabFC info) tm -- (in argument, guarded, in type, in qquote)+ est <- getAux+ sequence_ (delayed_elab est) end_unify ptm <- get_term when pattern -- convert remaining holes to pattern vars@@ -166,11 +216,11 @@ toElab ina arg = case getTm arg of Placeholder -> Nothing- v -> Just (priority arg, elabE ina v)+ v -> Just (priority arg, elabE ina (elabFC info) v) toElab' ina arg = case getTm arg of Placeholder -> Nothing- v -> Just (elabE ina v)+ v -> Just (elabE ina (elabFC info) v) mkPat = do hs <- get_holes tm <- get_term@@ -182,31 +232,41 @@ -- and forces/delays. If you make a recursive call in elab', it is -- normally correct to call elabE - the ones that don't are desugarings -- typically- elabE :: (Bool, Bool, Bool, Bool) -> PTerm -> ElabD ()- elabE ina t =- --do g <- goal- --trace ("Elaborating " ++ show t ++ " : " ++ show g) $- do ct <- insertCoerce ina t- t' <- insertLazy ct- g <- goal- tm <- get_term- ps <- get_probs- hs <- get_holes- --trace ("Elaborating " ++ show t' ++ " in " ++ show g- -- ++ "\n" ++ show tm- -- ++ "\nholes " ++ show hs- -- ++ "\nproblems " ++ show ps- -- ++ "\n-----------\n") $- --trace ("ELAB " ++ show t') $- let fc = fileFC "Force"- env <- get_env- handleError (forceErr env)- (elab' ina t')- (elab' ina (PApp fc (PRef fc (sUN "Force"))- [pimp (sUN "t") Placeholder True,- pimp (sUN "a") Placeholder True,- pexp ct])) True+ elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()+ elabE ina fc' t =+ --do g <- goal+ --trace ("Elaborating " ++ show t ++ " : " ++ show g) $+ do solved <- get_recents+ as <- get_autos+ -- If any of the autos use variables which have recently been solved,+ -- have another go at solving them now.+ mapM_ (\(a, ns) -> if any (\n -> n `elem` solved) ns+ then solveAuto ist fn False a+ else return ()) as+ + itm <- if not pattern then insertImpLam t else return t+ ct <- insertCoerce ina itm+ t' <- insertLazy ct+ g <- goal+ tm <- get_term+ ps <- get_probs+ hs <- get_holes + --trace ("Elaborating " ++ show t' ++ " in " ++ show g+ -- ++ "\n" ++ show tm+ -- ++ "\nholes " ++ show hs+ -- ++ "\nproblems " ++ show ps+ -- ++ "\n-----------\n") $+ --trace ("ELAB " ++ show t') $+ let fc = fileFC "Force"+ env <- get_env+ handleError (forceErr env)+ (elab' ina fc' t')+ (elab' ina fc' (PApp fc (PRef fc (sUN "Force"))+ [pimp (sUN "t") Placeholder True,+ pimp (sUN "a") Placeholder True,+ pexp ct])) True+ forceErr env (CantUnify _ t t' _ _ _) | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t), ht == txt "Lazy'" = True@@ -234,36 +294,43 @@ -- "guarded" means immediately under a constructor, to help find patvars - elab' :: (Bool, Bool, Bool, Bool) -- ^ (in an argument, guarded, in a type, in a quasiquote)+ elab' :: ElabCtxt -- ^ (in an argument, guarded, in a type, in a quasiquote)+ -> Maybe FC -- ^ The closest FC in the syntax tree, if applicable -> PTerm -- ^ The term to elaborate -> ElabD ()- elab' ina (PNoImplicits t) = elab' ina t -- skip elabE step- elab' ina PType = do apply RType []; solve- elab' ina (PUniverse u) = do apply (RUType u) []; solve+ elab' ina fc (PNoImplicits t) = elab' ina fc t -- skip elabE step+ elab' ina fc PType = do apply RType []; solve+ elab' ina fc (PUniverse u) = do apply (RUType u) []; solve -- elab' (_,_,inty) (PConstant c) -- | constType c && pattern && not reflection && not inty -- = lift $ tfail (Msg "Typecase is not allowed")- elab' ina (PConstant c) = do apply (RConstant c) []; solve- elab' ina (PQuote r) = do fill r; solve- elab' ina (PTrue fc _) =+ elab' ina fc tm@(PConstant c) + | pattern && not reflection && not (e_qq ina) && not (e_intype ina)+ && isTypeConst c+ = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)+ | pattern && not reflection && e_nomatching ina+ = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)+ | otherwise = do apply (RConstant c) []; solve+ elab' ina fc (PQuote r) = do fill r; solve+ elab' ina _ (PTrue fc _) = do hnf_compute g <- goal case g of- TType _ -> elab' ina (PRef fc unitTy)- _ -> elab' ina (PRef fc unitCon)- elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes+ TType _ -> 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- elab' ina (PResolveTC fc)+ elab' ina fc (PResolveTC fc') = do c <- getNameFrom (sMN 0 "class") instanceArg c- elab' ina (PRefl fc t)- = elab' ina (PApp fc (PRef fc eqCon) [pimp (sMN 0 "A") Placeholder True,- pimp (sMN 0 "x") t False])- elab' ina (PEq fc Placeholder Placeholder l r)+ elab' ina _ (PRefl fc t)+ = elab' ina (Just fc) (PApp fc (PRef fc eqCon) [pimp (sMN 0 "A") Placeholder True,+ pimp (sMN 0 "x") t False])+ elab' ina _ (PEq fc Placeholder Placeholder l r) = try (do tyn <- getNameFrom (sMN 0 "aqty") claim tyn RType movelast tyn- elab' ina (PApp fc (PRef fc eqTy)+ elab' ina (Just fc) (PApp fc (PRef fc eqTy) [pimp (sUN "A") (PRef fc tyn) True, pimp (sUN "B") (PRef fc tyn) False, pexp l, pexp r]))@@ -273,26 +340,26 @@ movelast atyn claim btyn RType movelast btyn- elab' ina (PApp fc (PRef fc eqTy)- [pimp (sUN "A") (PRef fc atyn) True,- pimp (sUN "B") (PRef fc btyn) False,- pexp l, pexp r]))+ elab' ina (Just fc) (PApp fc (PRef fc eqTy)+ [pimp (sUN "A") (PRef fc atyn) True,+ pimp (sUN "B") (PRef fc btyn) False,+ pexp l, pexp r])) - elab' ina (PEq fc lt rt l r) = elab' ina (PApp fc (PRef fc eqTy)- [pimp (sUN "A") lt True,- pimp (sUN "B") rt False,- pexp l, pexp r])- elab' ina@(_, a, inty, qq) (PPair fc _ l r)+ elab' ina _ (PEq fc lt rt l r) = elab' ina (Just fc) (PApp fc (PRef fc eqTy)+ [pimp (sUN "A") lt True,+ pimp (sUN "B") rt False,+ pexp l, pexp r])+ elab' ina _ (PPair fc _ l r) = do hnf_compute g <- goal case g of- TType _ -> elab' ina (PApp fc (PRef fc pairTy)+ TType _ -> elab' ina (Just fc) (PApp fc (PRef fc pairTy) [pexp l,pexp r])- _ -> elab' ina (PApp fc (PRef fc pairCon)+ _ -> 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 (PDPair fc p l@(PRef _ n) t r)+ elab' ina _ (PDPair fc p l@(PRef _ n) t r) = case t of Placeholder -> do hnf_compute@@ -301,18 +368,18 @@ TType _ -> asType _ -> asValue _ -> asType- where asType = elab' ina (PApp fc (PRef fc sigmaTy)+ where asType = elab' ina (Just fc) (PApp fc (PRef fc sigmaTy) [pexp t,- pexp (PLam n Placeholder r)])- asValue = elab' ina (PApp fc (PRef fc existsCon)+ pexp (PLam fc n Placeholder r)])+ asValue = elab' ina (Just fc) (PApp fc (PRef fc existsCon) [pimp (sMN 0 "a") t False, pimp (sMN 0 "P") Placeholder True, pexp l, pexp r])- elab' ina (PDPair fc p l t r) = elab' ina (PApp fc (PRef fc existsCon)+ elab' ina _ (PDPair fc p l t r) = elab' ina (Just fc) (PApp fc (PRef fc existsCon) [pimp (sMN 0 "a") t False, pimp (sMN 0 "P") Placeholder True, pexp l, pexp r])- elab' ina (PAlternative True as)+ elab' ina fc (PAlternative True as) = do hnf_compute ty <- goal ctxt <- get_context@@ -322,26 +389,35 @@ -- trace (-- show tc ++ " " ++ show as ++ "\n ==> " ++ -- show (length as') ++ "\n" ++ -- showSep ", " (map showTmImpls as') ++ "\nEND") $- tryAll (zip (map (elab' ina) as') (map showHd as'))+ tryAll (zip (map (elab' ina fc) as') (map showHd as')) where showHd (PApp _ (PRef _ n) _) = n showHd (PRef _ n) = n showHd (PApp _ h _) = showHd h showHd x = NErased -- We probably should do something better than this here- elab' ina (PAlternative False as)+ elab' ina fc (PAlternative False as) = trySeq as where -- if none work, take the error from the first- trySeq (x : xs) = let e1 = elab' ina x in+ trySeq (x : xs) = let e1 = elab' ina fc x in try' e1 (trySeq' e1 xs) True trySeq' deferr [] = proofFail deferr trySeq' deferr (x : xs)- = try' (elab' ina x) (trySeq' deferr xs) True- elab' ina (PPatvar fc n) | bindfree = do patvar n; -- update_term liftPats+ = try' (do elab' ina fc x+ solveAutos ist fn False) (trySeq' deferr xs) True+ elab' ina _ (PPatvar fc n) | bindfree = do patvar n; update_term liftPats -- elab' (_, _, inty) (PRef fc f) -- | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty -- = lift $ tfail (Msg "Typecase is not allowed")- elab' (ina, guarded, inty, qq) (PRef fc n)- | (pattern || (bindfree && bindable n)) && not (inparamBlock n) && not qq- = do ctxt <- get_context+ elab' ec _ tm@(PRef fc n)+ | pattern && not reflection && not (e_qq ec) && not (e_intype ec)+ && isTConName n (tt_ctxt ist)+ = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)+ | pattern && not reflection && e_nomatching ec+ = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)+ | (pattern || (bindfree && bindable n)) && not (inparamBlock n) && not (e_qq ec)+ = do let ina = e_inarg ec+ guarded = e_guarded ec+ inty = e_intype ec+ ctxt <- get_context let defined = case lookupTy n ctxt of [] -> False _ -> True@@ -351,16 +427,29 @@ else if (defined && not guarded) then do apply (Var n) []; solve else try (do apply (Var n) []; solve)- (do patvar n; ) -- update_term liftPats)+ (do patvar n; update_term liftPats) where inparamBlock n = case lookupCtxtName n (inblock info) of [] -> False _ -> True bindable (NS _ _) = False bindable (UN xs) = True bindable n = implicitable n- elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])- elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve- elab' ina@(_, a, inty, qq) (PLam n Placeholder sc)+ elab' ina _ f@(PInferRef fc n) = elab' ina (Just fc) (PApp fc f [])+ elab' ina fc' tm@(PRef fc n) + | pattern && not reflection && not (e_qq ina) && not (e_intype ina)+ && isTConName n (tt_ctxt ist)+ = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)+ | pattern && not reflection && e_nomatching ina+ = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)+ | otherwise = + do fty <- get_type (Var n) -- check for implicits+ ctxt <- get_context+ env <- get_env + let a' = insertScopedImps fc (normalise ctxt env fty) []+ if null a'+ then erun fc $ do apply (Var n) []; solve+ else elab' ina fc' (PApp fc tm [])+ elab' ina _ (PLam fc n Placeholder sc) = do -- if n is a type constructor name, this makes no sense... ctxt <- get_context when (isTConName n ctxt) $@@ -368,8 +457,8 @@ checkPiGoal n attack; intro (Just n); -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)- elabE (True, a, inty, qq) sc; solve- elab' ina@(_, a, inty, qq) (PLam n ty sc)+ elabE (ina { e_inarg = True } ) (Just fc) sc; solve+ elab' ec _ (PLam fc n ty sc) = do tyn <- getNameFrom (sMN 0 "lamty") -- if n is a type constructor name, this makes no sense... ctxt <- get_context@@ -383,23 +472,27 @@ hs <- get_holes introTy (Var tyn) (Just n) focus tyn- elabE (True, a, True, qq) ty- elabE (True, a, inty, qq) sc+ + elabE (ec { e_inarg = True, e_intype = True }) (Just fc) ty+ elabE (ec { e_inarg = True }) (Just fc) sc solve- elab' ina@(_, a, _, qq) (PPi _ n Placeholder sc)- = do attack; arg n (sMN 0 "ty"); elabE (True, a, True, qq) sc; solve- elab' ina@(_, a, _, qq) (PPi _ n ty sc)+ elab' ina fc (PPi p n Placeholder sc)+ = do attack; arg n (is_scoped p) (sMN 0 "ty") + elabE (ina { e_inarg = True, e_intype = True }) fc sc+ solve+ elab' ina fc (PPi p n ty sc) = do attack; tyn <- getNameFrom (sMN 0 "ty") claim tyn RType n' <- case n of MN _ _ -> unique_hole n _ -> return n- forall n' (Var tyn)+ forall n' (is_scoped p) (Var tyn) focus tyn- elabE (True, a, True, qq) ty- elabE (True, a, True, qq) sc+ let ec' = ina { e_inarg = True, e_intype = True }+ elabE ec' fc ty+ elabE ec' fc sc solve- elab' ina@(_, a, inty, qq) (PLet n ty val sc)+ elab' ina _ (PLet fc n ty val sc) = do attack ivs <- get_instances tyn <- getNameFrom (sMN 0 "letty")@@ -412,18 +505,19 @@ Placeholder -> return () _ -> do focus tyn explicit tyn- elabE (True, a, True, qq) ty+ elabE (ina { e_inarg = True, e_intype = True }) + (Just fc) ty focus valn- elabE (True, a, True, qq) val+ elabE (ina { e_inarg = True, e_intype = True }) + (Just fc) val ivs' <- get_instances env <- get_env- elabE (True, a, inty, qq) sc+ elabE (ina { e_inarg = True }) (Just fc) sc when (not pattern) $ mapM_ (\n -> do focus n g <- goal hs <- get_holes if all (\n -> n == tyn || not (n `elem` hs)) (freeNames g)- -- let insts = filter tcname $ map fst (ctxtAlist (tt_ctxt ist)) then try (resolveTC True 7 g fn ist) (movelast n) else movelast n)@@ -433,7 +527,7 @@ expandLet n (case lookup n env of Just (Let t v) -> v) solve- elab' ina@(_, a, inty, qq) (PGoal fc r n sc) = do+ elab' ina _ (PGoal fc r n sc) = do rty <- goal attack tyn <- getNameFrom (sMN 0 "letty")@@ -442,14 +536,14 @@ claim valn (Var tyn) letbind n (Var tyn) (Var valn) focus valn- elabE (True, a, True, qq) (PApp fc r [pexp (delab ist rty)])+ elabE (ina { e_inarg = True, e_intype = True }) (Just fc) (PApp fc r [pexp (delab ist rty)]) env <- get_env computeLet n- elabE (True, a, inty, qq) sc+ elabE (ina { e_inarg = True }) (Just fc) sc solve--- elab' ina (PLet n Placeholder+-- elab' ina fc (PLet n Placeholder -- (PApp fc r [pexp (delab ist rty)]) sc)- elab' ina tm@(PApp fc (PInferRef _ f) args) = do+ elab' ina _ tm@(PApp fc (PInferRef _ f) args) = do rty <- goal ds <- get_deferred ctxt <- get_context@@ -478,7 +572,7 @@ ans <- claimArgTys env xs return ((aval, (True, (Var an))) : ans) fnTy [] ret = forget ret- fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi xt RType) (fnTy xs ret)+ fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi Nothing xt RType) (fnTy xs ret) localVar env (PRef _ x) = case lookup x env of@@ -486,7 +580,8 @@ _ -> Nothing localVar env _ = Nothing - elabIArg ((n, (True, ty)), def) = do focus n; elabE ina (getTm def)+ elabIArg ((n, (True, ty)), def) =+ do focus n; elabE ina (Just fc) (getTm def) elabIArg _ = return () -- already done, just a name mkN n@(NS _ _) = n@@ -495,7 +590,7 @@ Just xs@(_:_) -> sNS n xs _ -> n - elab' ina (PMatchApp fc fn)+ elab' ina _ (PMatchApp fc fn) = do (fn', imps) <- case lookupCtxtName fn (idris_implicits ist) of [(n, args)] -> return (n, map (const True) args) _ -> lift $ tfail (NoSuchVariable fn)@@ -507,12 +602,28 @@ -- | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty && not qq -- = lift $ tfail (Msg "Typecase is not allowed") -- if f is local, just do a simple_app- elab' (ina, g, inty, qq) tm@(PApp fc (PRef _ f) args)+ elab' ina _ tm@(PApp fc (PRef _ f) args_in)+ | pattern && not reflection && e_nomatching ina+ = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)+ | otherwise = do env <- get_env- if (f `elem` map fst env && length args == 1)+ ty <- goal+ fty <- get_type (Var f)+ ctxt <- get_context+ let args = insertScopedImps fc (normalise ctxt env fty) args_in+ let unmatchableArgs = if pattern + then getUnmatchable (tt_ctxt ist) f+ else []+ -- Dot it if we're in a pattern and it isn't a constructor+-- when (pattern && not (isDConName f ctxt) && f /= fn) $ dotterm++ 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, g, inty, qq) (PRef fc f))- (elabE (True, g, inty, qq) (getTm (head args)))+ do simple_app (elabE ina (Just fc) (PRef fc f))+ (elabE (ina { e_inarg = True }) (Just fc) (getTm (head args))) (show tm) solve else@@ -528,7 +639,6 @@ _ -> do mapM_ setInjective (map getTm args) -- maybe more things are solvable now unifyProblems- ctxt <- get_context let guarded = isConName f ctxt -- trace ("args is " ++ show args) $ return () ns <- apply (Var f) (map isph args)@@ -541,21 +651,22 @@ let (ns', eargs) = unzip $ sortBy cmpArg (zip ns args) ulog <- getUnifyLog- elabArgs ist (ina || not isinf, guarded, inty, qq)- [] fc False f ns'+ elabArgs ist (ina { e_inarg = e_inarg ina || not isinf }) + [] fc False f + (zip ns' (unmatchableArgs ++ repeat False)) (f == sUN "Force") (map (\x -> getTm x) eargs) -- TODO: remove this False arg solve ivs' <- get_instances -- Attempt to resolve any type classes which have 'complete' types, -- i.e. no holes in them- when (not pattern || (ina && not tcgen && not guarded)) $+ 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)- -- let insts = filter tcname $ map fst (ctxtAlist (tt_ctxt ist)) then try (resolveTC False 7 g fn ist) (movelast n) else movelast n)@@ -577,16 +688,18 @@ PAlternative False _ -> 5 PAlternative True _ -> 2 PTactics _ -> 150- PLam _ _ _ -> 3+ PLam _ _ _ _ -> 3 PRewrite _ _ _ _ -> 4 PResolveTC _ -> 0+ PHidden _ -> 150 _ -> 1 constraint (PConstraint _ _ _ _) = True constraint _ = False -- Score a point for every level where there is a non-constructor- -- function (so higher score --> done later)+ -- function (so higher score --> done later), and lots of points+ -- if there is a PHidden since this should be unifiable. -- Only relevant when on lhs conDepth d t | not pattern = 0 conDepth d (PRef _ f) | isConName f (tt_ctxt ist) = 0@@ -595,6 +708,7 @@ = conDepth d f + sum (map (conDepth (d+1)) (map getTm as)) conDepth d (PPatvar _ _) = 0 conDepth d (PAlternative _ as) = maximum (map (conDepth d) as)+ conDepth d (PHidden _) = 150 conDepth d Placeholder = 0 conDepth d (PResolveTC _) = 0 conDepth d t = max (100 - d) 1@@ -630,14 +744,15 @@ setInjective (PApp _ (PRef _ n) _) = setinj n setInjective _ = return () - elab' ina@(_, a, inty, qq) tm@(PApp fc f [arg])+ elab' ina _ tm@(PApp fc f [arg]) = erun fc $- do simple_app (elabE ina f) (elabE (True, a, inty, qq) (getTm arg))+ do simple_app (elabE ina (Just fc) f) (elabE (ina { e_inarg = True }) (Just fc) (getTm arg)) (show tm) solve- elab' ina Placeholder = do (h : hs) <- get_holes- movelast h- elab' ina (PMetavar n) =+ elab' ina fc Placeholder + = do (h : hs) <- get_holes+ movelast h+ elab' ina fc (PMetavar n) = do ptm <- get_term -- When building the metavar application, leave out the unique -- names which have been used elsewhere in the term, since we@@ -651,12 +766,12 @@ mkN n = case namespace info of Just xs@(_:_) -> sNS n xs _ -> n- elab' ina (PProof ts) = do compute; mapM_ (runTac True ist fn) ts- elab' ina (PTactics ts)- | not pattern = do mapM_ (runTac False ist fn) ts- | otherwise = elab' ina Placeholder- elab' ina (PElabError e) = fail (pshow ist e)- elab' ina (PRewrite fc r sc newg)+ elab' ina fc (PProof ts) = do compute; mapM_ (runTac True ist (elabFC info) fn) ts+ elab' ina fc (PTactics ts)+ | not pattern = do mapM_ (runTac False ist fc fn) ts+ | otherwise = elab' ina fc Placeholder+ elab' ina fc (PElabError e) = lift $ tfail e+ elab' ina _ (PRewrite fc r sc newg) = do attack tyn <- getNameFrom (sMN 0 "rty") claim tyn RType@@ -665,14 +780,14 @@ letn <- getNameFrom (sMN 0 "_rewrite_rule") letbind letn (Var tyn) (Var valn) focus valn- elab' ina r+ elab' ina (Just fc) r compute g <- goal rewrite (Var letn) g' <- goal when (g == g') $ lift $ tfail (NoRewriting g) case newg of- Nothing -> elab' ina sc+ Nothing -> elab' ina (Just fc) sc Just t -> doEquiv t sc solve where doEquiv t sc =@@ -684,12 +799,12 @@ letn <- getNameFrom (sMN 0 "equiv_val") letbind letn (Var tyn) (Var valn) focus tyn- elab' ina t+ elab' ina (Just fc) t focus valn- elab' ina sc- elab' ina (PRef fc letn)+ elab' ina (Just fc) sc+ elab' ina (Just fc) (PRef fc letn) solve- elab' ina@(_, a, inty, qq) c@(PCase fc scr opts)+ elab' ina _ c@(PCase fc scr opts) = do attack tyn <- getNameFrom (sMN 0 "scty") claim tyn RType@@ -698,7 +813,7 @@ claim valn (Var tyn) letbind scvn (Var tyn) (Var valn) focus valn- elabE (True, a, inty, qq) scr+ elabE (ina { e_inarg = True }) (Just fc) scr -- Solve any remaining implicits - we need to solve as many -- as possible before making the 'case' type unifyProblems@@ -714,7 +829,7 @@ cname <- unique_hole' True (mkCaseName fn) let cname' = mkN cname--- elab' ina (PMetavar cname')+-- elab' ina fc (PMetavar cname') attack; defer argsDropped cname'; solve -- if the scrutinee is one of the 'args' in env, we should@@ -723,7 +838,7 @@ (caseBlock fc cname' (map (isScr scr) (reverse args')) opts) -- elaborate case- updateAux (newdef : )+ updateAux (\e -> e { case_decls = newdef : case_decls e } ) -- if we haven't got the type yet, hopefully we'll get it later! movelast tyn solve@@ -760,26 +875,10 @@ = n `elem` ns || any (\x -> x `elem` ns) (allTTNames (binderTy b)) - -- FIXME: This probably doesn't help us here, but leaving- -- it in temporarily... if this comment is still here in master,- -- please delete the code!- chaseDeps env acc [] = filter (\(n, _) -> n `elem` acc) env- chaseDeps env acc ((n,b) : args)- = let ns = allTTNames (binderTy b) in- extendAcc ns acc args- where- extendAcc [] acc args = chaseDeps env acc args- extendAcc (n:ns) acc args- | elem n acc = extendAcc ns acc args- | otherwise = case lookup n env of- Just b -> extendAcc ns (n : acc)- ((n,b) : args)- Nothing -> extendAcc ns acc args-- elab' ina (PUnifyLog t) = do unifyLog True- elab' ina t- unifyLog False- elab' (ina, g, inty, qq) (PQuasiquote t goal) -- TODO: goal type+ elab' ina fc (PUnifyLog t) = do unifyLog True+ elab' ina fc t+ unifyLog False+ elab' ina fc (PQuasiquote t goal) -- TODO: goal type = do -- First extract the unquoted subterms, replacing them with fresh -- names in the quasiquoted term. Claim their reflections to be -- of type TT.@@ -824,11 +923,11 @@ case goal of Nothing -> return () Just gTy -> do focus qTy- elabE (ina, g, inty, True) gTy+ elabE (ina { e_qq = True }) fc gTy -- Elaborate the quasiquoted term into the hole focus qTm- elabE (ina, g, inty, True) t+ elabE (ina { e_qq = True }) fc t end_unify -- We now have an elaborated term. Reflect it and solve the@@ -854,12 +953,29 @@ elabUnquote (n, tm) = do focus n- elabE (ina, g, inty, False) tm+ elabE (ina { e_qq = False }) fc tm - elab' ina (PUnquote t) = fail "Found unquote outside of quasiquote"- elab' ina x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x+ elab' ina fc (PUnquote t) = fail "Found unquote outside of quasiquote"+ elab' ina fc (PAs _ n t) = lift . tfail . Msg $ "@-pattern not allowed here"+ elab' ina fc (PHidden t) + | reflection = elab' ina fc t+ | otherwise+ = do (h : hs) <- get_holes+ -- Dotting a hole means that either the hole or any outer+ -- hole (a hole outside any occurrence of it) + -- must be solvable by unification as well as being filled+ -- in directly.+ -- Delay dotted things to the end, then when we elaborate them+ -- we can check the result against what was inferred+ movelast h+ delayElab $ do focus h+ dotterm+ elab' ina fc t+ elab' ina fc x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x + delayElab t = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [t] }) + isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term)) isScr (PRef _ n) (n', b) = (n', (n == n', b)) isScr _ (n', b) = (n', (False, b))@@ -943,6 +1059,27 @@ notImplicitable (PCase _ _ _) = True notImplicitable _ = False + insertScopedImps fc (Bind n (Pi im@(Just i) _ _) sc) xs+ | tcinstance i+ = pimp n (PResolveTC fc) True : insertScopedImps fc sc xs+ | otherwise+ = pimp n Placeholder True : insertScopedImps fc sc xs+ insertScopedImps fc (Bind n (Pi _ _ _) sc) (x : xs)+ = x : insertScopedImps fc sc xs+ insertScopedImps _ _ xs = xs++ insertImpLam 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 _ t = return t+ insertCoerce ina t@(PCase _ _ _) = return t insertCoerce ina t | notImplicitable t = return t insertCoerce ina t =@@ -965,22 +1102,28 @@ -- | Elaborate the arguments to a function elabArgs :: IState -- ^ The current Idris state- -> (Bool, Bool, Bool, Bool) -- ^ (in an argument, guarded, in a type, in a qquote)+ -> ElabCtxt -- ^ (in an argument, guarded, in a type, in a qquote) -> [Bool] -> FC -- ^ Source location -> Bool -> Name -- ^ Name of the function being applied- -> [(Name, Name)] -- ^ (Argument Name, Hole Name)+ -> [((Name, Name), Bool)] -- ^ (Argument Name, Hole Name, unmatchable) -> Bool -- ^ under a 'force'- -> [PTerm] -- ^ (Laziness, argument)+ -> [PTerm] -- ^ argument -> ElabD () elabArgs ist ina failed fc retry f [] force _ = return ()- elabArgs ist ina failed fc r f (n:ns) force (Placeholder : args)- = elabArgs ist ina failed fc r f ns force args- elabArgs ist ina failed fc r f ((argName, holeName):ns) force (t : args)- = elabArg argName holeName t- where elabArg argName holeName t =- do now_elaborating fc f argName+ elabArgs ist ina failed fc r f (((argName, holeName), unm):ns) force (t : args)+ = do hs <- get_holes+ if holeName `elem` hs then + do focus holeName+ case t of+ Placeholder -> do movelast holeName+ elabArgs ist ina failed fc r f ns force args+ _ -> elabArg t+ else elabArgs ist ina failed fc r f ns force args+ where elabArg t =+ do -- solveAutos ist fn False+ now_elaborating fc f argName wrapErr f argName $ do hs <- get_holes tm <- get_term@@ -989,13 +1132,14 @@ let elab = if force then elab' else elabE failed' <- -- trace (show (n, t, hs, tm)) $ -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $- case holeName `elem` hs of- True -> do focus holeName;- g <- goal- ulog <- getUnifyLog- traceWhen ulog ("Elaborating argument " ++ show (argName, holeName, g)) $- elab ina t; return failed- False -> return failed+ do focus holeName;+ g <- goal+ -- Can't pattern match on polymorphic goals+ poly <- goal_polymorphic+ ulog <- getUnifyLog+ traceWhen ulog ("Elaborating argument " ++ show (argName, holeName, g)) $+ elab (ina { e_nomatching = unm && poly }) (Just fc) t+ return failed done_elaborating_arg f argName elabArgs ist ina failed fc r f ns force args wrapErr f argName action =@@ -1049,6 +1193,7 @@ | otherwise = locallyBound ts getName (PRef _ n) = Just n getName (PApp _ f _) = getName f+ getName (PHidden t) = getName t getName _ = Nothing pruneByType env (P _ n _) ctxt as@@ -1066,6 +1211,7 @@ headIs var f (PApp _ (PRef _ f') _) = typeHead var f f' headIs var f (PApp _ f' _) = headIs var f f' headIs var f (PPi _ _ _ sc) = headIs var f sc+ headIs var f (PHidden t) = headIs var f t headIs _ _ _ = True -- keep if it's not an application typeHead var f f'@@ -1090,20 +1236,39 @@ _ -> [] | otherwise = [] +-- Try again to solve auto implicits+solveAuto :: IState -> Name -> Bool -> Name -> ElabD ()+solveAuto ist fn ambigok n+ = do hs <- get_holes+ when (n `elem` hs) $ do+ focus n+ g <- goal+ isg <- is_guess -- if it's a guess, we're working on it recursively, so stop+ when (not isg) $+ proofSearch' ist True ambigok 100 True Nothing fn []++solveAutos :: IState -> Name -> Bool -> ElabD ()+solveAutos ist fn ambigok+ = do autos <- get_autos+ mapM_ (solveAuto ist fn ambigok) (map fst autos)+ trivial' ist = trivial (elab ist toplevel ERHS [] (sMN 0 "tac")) ist-proofSearch' ist rec depth prv top n hints+proofSearch' ist rec ambigok depth prv top n hints = do unifyProblems- proofSearch rec prv depth+ proofSearch rec prv ambigok (not prv) depth (elab ist toplevel ERHS [] (sMN 0 "tac")) top n hints ist +-- Resolve type classes. This will only pick up 'normal' instances, never+-- named instances (hence using 'tcname' to check it's a generated instance+-- name). resolveTC :: Bool -> Int -> Term -> Name -> IState -> ElabD () resolveTC = resTC' [] resTC' tcs def 0 topg fn ist = fail $ "Can't resolve type class" resTC' tcs def 1 topg fn ist = try' (trivial' ist) (resolveTC def 0 topg fn ist) True resTC' tcs defaultOn depth topg fn ist- = do hnf_compute+ = do compute g <- goal ptm <- get_term ulog <- getUnifyLog@@ -1113,12 +1278,13 @@ (do t <- goal let (tc, ttypes) = unApply t scopeOnly <- needsDefault t tc ttypes+ let stk = elab_stack ist let insts_in = findInstances ist t let insts = if scopeOnly then filter chaser insts_in else insts_in tm <- get_term let depth' = if scopeOnly then 2 else depth- blunderbuss t depth' insts) True+ blunderbuss t depth' stk (stk ++ insts)) True where elabTC n | n /= fn && tcname n = (resolve n depth, show n) | otherwise = (fail "Can't resolve", show n)@@ -1145,13 +1311,13 @@ boundVar (P Bound _ _) = True boundVar _ = False - blunderbuss t d [] = do -- c <- get_env+ blunderbuss t d stk [] = do -- c <- get_env -- ps <- get_probs lift $ tfail $ CantResolve topg- blunderbuss t d (n:ns)- | n /= fn && tcname n = try' (resolve n d)- (blunderbuss t d ns) True- | otherwise = blunderbuss t d ns+ blunderbuss t d stk (n:ns)+ | n /= fn && (n `elem` stk || tcname n) + = try' (resolve n d) (blunderbuss t d stk ns) True+ | otherwise = blunderbuss t d stk ns resolve n depth | depth == 0 = fail $ "Can't resolve type class"@@ -1227,8 +1393,8 @@ -- Running tactics directly -- if a tactic adds unification problems, return an error -runTac :: Bool -> IState -> Name -> PTactic -> ElabD ()-runTac autoSolve ist fn tac+runTac :: Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()+runTac autoSolve ist perhapsFC fn tac = do env <- get_env g <- goal let tac' = fmap (addImplBound ist (map fst env)) tac@@ -1347,7 +1513,7 @@ runT Trivial = do trivial' ist; when autoSolve solveAll runT TCInstance = runT (Exact (PResolveTC emptyFC)) runT (ProofSearch rec prover depth top hints)- = do proofSearch' ist rec depth prover top fn hints+ = do proofSearch' ist rec False depth prover top fn hints when autoSolve solveAll runT (Focus n) = focus n runT Solve = solve@@ -1381,9 +1547,9 @@ where tacticTy = Var (reflm "Tactic") listTy = Var (sNS (sUN "List") ["List", "Prelude"]) scriptTy = (RBind (sMN 0 "__pi_arg")- (Pi (RApp listTy envTupleType) RType)+ (Pi Nothing (RApp listTy envTupleType) RType) (RBind (sMN 1 "__pi_arg")- (Pi (Var $ reflm "TT") RType) tacticTy))+ (Pi Nothing (Var $ reflm "TT") RType) tacticTy)) runT (ByReflection tm) -- run the reflection function 'tm' on the -- goal, then apply the resulting reflected Tactic = do tgoal <- goal@@ -1427,7 +1593,7 @@ ctxt <- get_context env <- get_env let value' = hnf ctxt env value- runTac autoSolve ist fn (Exact $ PQuote (reflect value'))+ runTac autoSolve ist perhapsFC fn (Exact $ PQuote (reflect value')) runT (Fill v) = do attack -- let x = fill x in ... tyn <- getNameFrom (sMN 0 "letty") claim tyn RType@@ -1442,7 +1608,7 @@ env <- get_env let value' = normalise ctxt env value rawValue <- reifyRaw value'- runTac autoSolve ist fn (Exact $ PQuote rawValue)+ runTac autoSolve ist perhapsFC fn (Exact $ PQuote rawValue) runT (GoalType n tac) = do g <- goal case unApply g of (P _ n' _, _) ->@@ -1454,10 +1620,31 @@ return () runT Skip = return () runT (TFail err) = lift . tfail $ ReflectionError [err] (Msg "")+ runT SourceFC =+ case perhapsFC of+ Nothing -> lift . tfail $ Msg "There is no source location available."+ Just fc ->+ do 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)+ ]+ ]+ solve runT x = fail $ "Not implemented " ++ show x runReflected t = do t' <- reify ist t- runTac autoSolve ist fn t'+ runTac autoSolve ist perhapsFC fn t' -- | Prefix a name with the "Language.Reflection" namespace reflm :: String -> Name@@ -1472,6 +1659,7 @@ reify _ (P _ n _) | n == reflm "Solve" = return Solve reify _ (P _ n _) | n == reflm "Compute" = return Compute reify _ (P _ n _) | n == reflm "Skip" = return Skip+reify _ (P _ n _) | n == reflm "SourceFC" = return SourceFC reify ist t@(App _ _) | (P _ f _, args) <- unApply t = reifyApp ist f args reify _ t = fail ("Unknown tactic " ++ show t)@@ -1634,7 +1822,7 @@ reifyTTBinderApp reif f [t] | f == reflm "Lam" = liftM Lam (reif t) reifyTTBinderApp reif f [t, k]- | f == reflm "Pi" = liftM2 Pi (reif t) (reif k)+ | f == reflm "Pi" = liftM2 (Pi Nothing) (reif t) (reif k) reifyTTBinderApp reif f [x, y] | f == reflm "Let" = liftM2 Let (reif x) (reif y) reifyTTBinderApp reif f [x, y]@@ -1777,7 +1965,7 @@ fill $ reflCall "Lam" [Var (reflm "TT"), Var t'] solve focus t'; reflectQuotePattern unq t- reflectBinderQuotePattern unq (Pi t k)+ 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']@@ -1927,7 +2115,7 @@ reflectBinderQuote :: [Name] -> Binder Term -> Raw reflectBinderQuote unq (Lam t) = reflCall "Lam" [Var (reflm "TT"), reflectQuote unq t]-reflectBinderQuote unq (Pi t k)+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]@@ -2079,6 +2267,8 @@ reflectErr (TooManyArguments n) = raw_apply (Var $ reflErrName "TooManyArguments") [reflectName n] reflectErr (CantIntroduce t) = raw_apply (Var $ reflErrName "CantIntroduce") [reflect t] reflectErr (NoSuchVariable n) = raw_apply (Var $ reflErrName "NoSuchVariable") [reflectName n]+reflectErr (WithFnType t) = raw_apply (Var $ reflErrName "WithFnType") [reflect t]+reflectErr (CantMatch t) = raw_apply (Var $ reflErrName "CantMatch") [reflect t] reflectErr (NoTypeDecl n) = raw_apply (Var $ reflErrName "NoTypeDecl") [reflectName n] reflectErr (NotInjective t1 t2 t3) = raw_apply (Var $ reflErrName "NotInjective")@@ -2190,7 +2380,7 @@ Right (TextPart msg) reifyReportPart (App (P (DCon _ _ _) n _) ttn) | n == reflm "NamePart" =- case runElab [] (reifyTTName ttn) (initElaborator NErased initContext Erased) of+ case runElab initEState (reifyTTName ttn) (initElaborator NErased initContext Erased) of Error e -> Left . InternalMsg $ "could not reify name term " ++ show ttn ++@@ -2198,7 +2388,7 @@ OK (n', _)-> Right $ NamePart n' reifyReportPart (App (P (DCon _ _ _) n _) tm) | n == reflm "TermPart" =- case runElab [] (reifyTT tm) (initElaborator NErased initContext Erased) of+ case runElab initEState (reifyTT tm) (initElaborator NErased initContext Erased) of Error e -> Left . InternalMsg $ "could not reify reflected term " ++ show tm ++
src/Idris/Erasure.hs view
@@ -300,7 +300,7 @@ casedVar = fromMaybe (error $ "nonpatvar in case: " ++ show n) (M.lookup n vs) getDepsAlt :: Name -> [Name] -> Vars -> VarInfo -> CaseAlt -> Deps- getDepsAlt fn es vs var (FnCase n ns sc) = error "an FnCase encountered" -- TODO: what's this?+ getDepsAlt fn es vs var (FnCase n ns sc) = M.empty -- can't use FnCase at runtime getDepsAlt fn es vs var (ConstCase c sc) = getDepsSC fn es vs sc getDepsAlt fn es vs var (DefaultCase sc) = getDepsSC fn es vs sc getDepsAlt fn es vs var (SucCase n sc)@@ -354,7 +354,7 @@ -- here we just push IM.empty on the de bruijn stack -- the args will be marked as used at the usage site | Lam ty <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body- | Pi ty _ <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body+ | Pi _ ty _ <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body -- let-bound variables can get partially evaluated -- it is sufficient just to plug the Cond in when the bound names are used
src/Idris/Error.hs view
@@ -17,7 +17,7 @@ import System.Console.Haskeline.MonadException import Control.Monad (when) import Control.Monad.State.Strict-import Control.Monad.Error (throwError, catchError)+import Control.Monad.Except (throwError, catchError) import System.IO.Error(isUserError, ioeGetErrorString) import Data.Char import Data.List (intercalate, isPrefixOf)@@ -28,8 +28,10 @@ iucheck :: Idris () iucheck = do tit <- typeInType+ ist <- getIState+ let cs = idris_constraints ist+ logLvl 7 $ "ALL CONSTRAINTS: " ++ show cs when (not tit) $- do ist <- getIState (tclift $ ucheck (idris_constraints ist)) `idrisCatch` (\e -> do setErrSpan (getErrSpan e) iputStrLn (pshow ist e))@@ -87,9 +89,9 @@ warnDisamb ist (PRef _ _) = return () warnDisamb ist (PInferRef _ _) = return () warnDisamb ist (PPatvar _ _) = return ()-warnDisamb ist (PLam _ t b) = warnDisamb ist t >> warnDisamb ist b+warnDisamb ist (PLam _ _ t b) = warnDisamb ist t >> warnDisamb ist b warnDisamb ist (PPi _ _ t b) = warnDisamb ist t >> warnDisamb ist b-warnDisamb ist (PLet _ x t b) = warnDisamb ist x >> warnDisamb ist t >> warnDisamb ist b+warnDisamb ist (PLet _ _ x t b) = warnDisamb ist x >> warnDisamb ist t >> warnDisamb ist b warnDisamb ist (PTyped x t) = warnDisamb ist x >> warnDisamb ist t warnDisamb ist (PApp _ t args) = warnDisamb ist t >> mapM_ (warnDisamb ist . getTm) args@@ -145,3 +147,4 @@ warnDisamb ist (PQuasiquote tm goal) = warnDisamb ist tm >> Foldable.mapM_ (warnDisamb ist) goal warnDisamb ist (PUnquote tm) = warnDisamb ist tm+warnDisamb ist (PAs _ _ tm) = warnDisamb ist tm
src/Idris/Help.hs view
@@ -1,9 +1,10 @@-module Idris.Help (CmdArg(..), help, extraHelp) where+module Idris.Help (CmdArg(..), extraHelp) where data CmdArg = ExprArg -- ^ The command takes an expression | NameArg -- ^ The command takes a name | FileArg -- ^ The command takes a file | ModuleArg -- ^ The command takes a module name+ | PkgArgs -- ^ The command takes a list of package names | NumberArg -- ^ The command takes a number | NamespaceArg -- ^ The command takes a namespace name | OptionArg -- ^ The command takes an option@@ -22,6 +23,7 @@ show NameArg = "<name>" show FileArg = "<filename>" show ModuleArg = "<module>"+ show PkgArgs = "<package list>" show NumberArg = "<number>" show NamespaceArg = "<namespace>" show OptionArg = "<option>"@@ -35,60 +37,14 @@ show (OptionalArg a) = "[" ++ show a ++ "]" show (SeqArgs a b) = show a ++ " " ++ show b -help :: [([String], CmdArg, String)]-help =- [ (["<expr>"], NoArg, "Evaluate an expression"),- ([":t"], ExprArg, "Check the type of an expression"),- ([":miss", ":missing"], NameArg, "Show missing clauses"),- ([":doc"], NameArg, "Show internal documentation"),- ([":mkdoc"], NamespaceArg, "Generate IdrisDoc for namespace(s) and dependencies"),- ([":apropos"], NoArg, "Search names, types, and documentation"),- ([":search", ":s"], ExprArg, "Search for values by type"),- ([":whocalls", ":wc"], NameArg, "List the callers of some name"),- ([":callswho", ":cw"], NameArg, "List the callees of some name"),- ([":total"], NameArg, "Check the totality of a name"),- ([":r",":reload"], NoArg, "Reload current file"),- ([":l",":load"], FileArg, "Load a new file"),- ([":cd"], FileArg, "Change working directory"),- ([":module"], ModuleArg, "Import an extra module"), -- NOTE: dragons- ([":e",":edit"], NoArg, "Edit current file using $EDITOR or $VISUAL"),- ([":m",":metavars"], NoArg, "Show remaining proof obligations (metavariables)"),- ([":p",":prove"], MetaVarArg, "Prove a metavariable"),- ([":a",":addproof"], NameArg, "Add proof to source file"),- ([":rmproof"], NameArg, "Remove proof from proof stack"),- ([":showproof"], NameArg, "Show proof"),- ([":proofs"], NoArg, "Show available proofs"),- ([":x"], ExprArg, "Execute IO actions resulting from an expression using the interpreter"),- ([":c",":compile"], FileArg, "Compile to an executable [codegen] <filename>"),- ([":exec",":execute"], NoArg, "Compile to an executable and run"),- ([":dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)"),- ([":dynamic"], NoArg, "List dynamically loaded C libraries"),- ([":?",":h",":help"], NoArg, "Display this help text"),- ([":set"], OptionArg, "Set an option (errorcontext, showimplicits)"),- ([":unset"], OptionArg, "Unset an option"),- ([":colour", ":color"], ColourArg, "Turn REPL colours on or off; set a specific colour"),- ([":consolewidth"], ConsoleWidthArg, "Set the width of the console"),- ([":q",":quit"], NoArg, "Exit the Idris system"),- ([":w", ":warranty"], NoArg, "Displays warranty information"),- ([":let"], ManyArgs DeclArg, "Evaluate a declaration, such as a function definition, instance implementation, or fixity declaration"),- ([":undefine",":unlet"], ManyArgs NameArg, "Remove the listed repl definitions, or all repl definitions if no names given"),- ([":printdef"], NameArg, "Show the definition of a function"),- ([":pp", ":pprint"], (SeqArgs OptionArg (SeqArgs NumberArg NameArg)), "Pretty prints an Idris function in either LaTeX or HTML and for a specified width.")- ]- -- | Use these for completion, but don't show them in :help extraHelp ::[([String], CmdArg, String)] extraHelp =- [ ([":casesplit", ":cs"], NoArg, ":cs <line> <name> splits the pattern variable on the line")- , ([":casesplit!", ":cs!"], NoArg, ":cs! <line> <name> destructively splits the pattern variable on the line")- , ([":addclause", ":ac"], NoArg, ":ac <line> <name> adds a clause for the definition of the name on the line")+ [ ([":casesplit!", ":cs!"], NoArg, ":cs! <line> <name> destructively splits the pattern variable on the line") , ([":addclause!", ":ac!"], NoArg, ":ac! <line> <name> destructively adds a clause for the definition of the name on the line")- , ([":addmissing", ":am"], NoArg, ":am <line> <name> adds all missing pattern matches for the name on the line") , ([":addmissing!", ":am!"], NoArg, ":am! <line> <name> destructively adds all missing pattern matches for the name on the line")- , ([":makewith", ":mw"], NoArg, ":mw <line> <name> adds a with clause for the definition of the name on the line") , ([":makewith!", ":mw!"], NoArg, ":mw! <line> <name> destructively adds a with clause for the definition of the name on the line")- , ([":proofsearch", ":ps"], NoArg, ":ps <line> <name> <names> does proof search for name on line, with names as hints") , ([":proofsearch!", ":ps!"], NoArg, ":ps! <line> <name> <names> destructively does proof search for name on line, with names as hints")- , ([":addproofclause", ":apc"], NoArg, ":apc <line> <name> adds a pattern-matching proof clause to name on line") , ([":addproofclause!", ":apc!"], NoArg, ":apc! <line> <name> destructively adds a pattern-matching proof clause to name on line")+ , ([":refine!", ":ref!"], NoArg, ":ref! <line> <name> <name'> destructively attempts to partially solve name on line, with name' as hint, introducing metavariables for arguments that aren't inferrable") ]
src/Idris/IBC.hs view
@@ -9,10 +9,12 @@ import Idris.AbsSyntax import Idris.Imports import Idris.Error+import Idris.DeepSeq import Idris.Delaborate import qualified Idris.Docstrings as D import Idris.Docstrings (Docstring) import Idris.Output+import Paths_idris import qualified Cheapskate.Types as CT @@ -24,6 +26,7 @@ import qualified Data.Set as S import Control.Monad+import Control.DeepSeq import Control.Monad.State.Strict hiding (get, put) import qualified Control.Monad.State.Strict as ST import System.FilePath@@ -32,48 +35,49 @@ import Util.Zlib (decompressEither) ibcVersion :: Word8-ibcVersion = 84+ibcVersion = 93 data IBCFile = IBCFile { ver :: Word8, sourcefile :: FilePath,- symbols :: [Name],- ibc_imports :: [FilePath],- ibc_importdirs :: [FilePath],- ibc_implicits :: [(Name, [PArg])],- ibc_fixes :: [FixDecl],- ibc_statics :: [(Name, [Bool])],- ibc_classes :: [(Name, ClassInfo)],- ibc_instances :: [(Bool, Name, Name)],- ibc_dsls :: [(Name, DSL)],- ibc_datatypes :: [(Name, TypeInfo)],- ibc_optimise :: [(Name, OptInfo)],- ibc_syntax :: [Syntax],- ibc_keywords :: [String],- ibc_objs :: [(Codegen, FilePath)],- ibc_libs :: [(Codegen, String)],- ibc_cgflags :: [(Codegen, String)],- ibc_dynamic_libs :: [String],- ibc_hdrs :: [(Codegen, String)],- ibc_access :: [(Name, Accessibility)],- ibc_total :: [(Name, Totality)],- ibc_totcheckfail :: [(FC, String)],- ibc_flags :: [(Name, [FnOpt])],- ibc_fninfo :: [(Name, FnInfo)],- ibc_cg :: [(Name, CGInfo)],- ibc_defs :: [(Name, Def)],- ibc_docstrings :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))],- ibc_transforms :: [(Name, (Term, Term))],- ibc_errRev :: [(Term, Term)],- ibc_coercions :: [Name],- ibc_lineapps :: [(FilePath, Int, PTerm)],- ibc_namehints :: [(Name, Name)],- ibc_metainformation :: [(Name, MetaInformation)],- ibc_errorhandlers :: [Name],- ibc_function_errorhandlers :: [(Name, Name, Name)], -- fn, arg, handler- ibc_metavars :: [(Name, (Maybe Name, Int, Bool))],- ibc_patdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))],- ibc_postulates :: [Name],- ibc_parsedSpan :: Maybe FC+ symbols :: ![Name],+ ibc_imports :: ![(Bool, FilePath)],+ ibc_importdirs :: ![FilePath],+ ibc_implicits :: ![(Name, [PArg])],+ ibc_fixes :: ![FixDecl],+ ibc_statics :: ![(Name, [Bool])],+ ibc_classes :: ![(Name, ClassInfo)],+ ibc_instances :: ![(Bool, Name, Name)],+ ibc_dsls :: ![(Name, DSL)],+ ibc_datatypes :: ![(Name, TypeInfo)],+ ibc_optimise :: ![(Name, OptInfo)],+ ibc_syntax :: ![Syntax],+ ibc_keywords :: ![String],+ ibc_objs :: ![(Codegen, FilePath)],+ ibc_libs :: ![(Codegen, String)],+ ibc_cgflags :: ![(Codegen, String)],+ ibc_dynamic_libs :: ![String],+ ibc_hdrs :: ![(Codegen, String)],+ ibc_access :: ![(Name, Accessibility)],+ ibc_total :: ![(Name, Totality)],+ ibc_totcheckfail :: ![(FC, String)],+ ibc_flags :: ![(Name, [FnOpt])],+ ibc_fninfo :: ![(Name, FnInfo)],+ ibc_cg :: ![(Name, CGInfo)],+ ibc_defs :: ![(Name, Def)],+ ibc_docstrings :: ![(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))],+ ibc_moduledocs :: ![(Name, Docstring D.DocTerm)],+ ibc_transforms :: ![(Name, (Term, Term))],+ ibc_errRev :: ![(Term, Term)],+ ibc_coercions :: ![Name],+ ibc_lineapps :: ![(FilePath, Int, PTerm)],+ ibc_namehints :: ![(Name, Name)],+ ibc_metainformation :: ![(Name, MetaInformation)],+ ibc_errorhandlers :: ![Name],+ ibc_function_errorhandlers :: ![(Name, Name, Name)], -- fn, arg, handler+ ibc_metavars :: ![(Name, (Maybe Name, Int, Bool))],+ ibc_patdefs :: ![(Name, ([([Name], Term, Term)], [PTerm]))],+ ibc_postulates :: ![Name],+ ibc_parsedSpan :: !(Maybe FC) } deriving Show {-!@@ -81,16 +85,28 @@ !-} initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing -loadIBC :: FilePath -> Idris ()-loadIBC fp = do imps <- getImported- when (not (fp `elem` imps)) $- do iLOG $ "Loading ibc " ++ fp+loadIBC :: Bool -- ^ True = reexport, False = make everything private + -> FilePath -> Idris ()+loadIBC reexport fp + = do imps <- getImported+ let redo = case lookup fp imps of+ Nothing -> True+ Just p -> not p && reexport+ when redo $+ do iLOG $ "Loading ibc " ++ fp ++ " " ++ show reexport ibcf <- runIO $ (bdecode fp :: IO IBCFile)- process ibcf fp- addImported fp+ process reexport ibcf fp+ addImported reexport fp +-- | Load an entire package from its index file+loadPkgIndex :: String -> Idris ()+loadPkgIndex pkg = do ddir <- runIO $ getDataDir+ addImportDir (ddir </> pkg)+ fp <- findPkgIndex pkg+ loadIBC True fp+ bencode :: Binary a => FilePath -> a -> IO () bencode f d = B.writeFile f (compress (encode d)) @@ -116,6 +132,22 @@ (\c -> do iLOG $ "Failed " ++ pshow i c) return () +-- Write a package index containing all the imports in the current IState+-- Used for ':search' of an entire package, to ensure everything is loaded.+writePkgIndex :: FilePath -> Idris ()+writePkgIndex f+ = do i <- getIState+ let imps = map (\ (x, y) -> (True, x)) $ idris_imported i+ iLOG $ "Writing package index " ++ show f ++ " including\n" +++ show (map snd imps)+ resetNameIdx+ let ibcf = initIBC { ibc_imports = imps }+ idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)+ runIO $ bencode f ibcf+ iLOG "Written")+ (\c -> do iLOG $ "Failed " ++ pshow i c)+ return ()+ mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile mkIBC [] f = return f mkIBC (i:is) f = do ist <- getIState@@ -160,67 +192,12 @@ ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f } ibc i (IBCDef n) f = do f' <- case lookupDefExact n (tt_ctxt i) of- Just v -> do (v', (f', _)) <- runStateT (updateDef v) (f, length (symbols f))- return f' { ibc_defs = (n,v) : ibc_defs f' }+ Just v -> return f { ibc_defs = (n,v) : ibc_defs f } _ -> ifail "IBC write failed" case lookupCtxtExact n (idris_patdefs i) of- Just v -> return f' { ibc_patdefs = (n,v) : ibc_patdefs f' }+ Just v -> return f' { ibc_patdefs = (n,v) : ibc_patdefs f } _ -> return f' -- Not a pattern definition- where - updateDef :: Def -> StateT (IBCFile, Int) Idris Def- updateDef (CaseOp c t args o s cd)- = do o' <- mapM updateOrig o- cd' <- updateCD cd- return (CaseOp c t args o' s cd')- updateDef t = return t - updateOrig (Left t) = do t' <- update t- return (Left t')- updateOrig (Right (l,r)) = do l' <- update l- r' <- update r- return (Right (l', r'))-- updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))- = do c' <- updateSC c; r' <- updateSC r- return (CaseDefs (ts, t) (cs, c') (is, i) (rs, r'))-- updateSC (Case up n alts) = do alts' <- mapM updateAlt alts- return (Case up n alts')- updateSC (ProjCase t alts) = do t' <- update t- alts' <- mapM updateAlt alts- return (ProjCase t' alts')- updateSC (STerm t) = do t' <- update t- return (STerm t')- updateSC t = return t-- updateAlt (ConCase n i a sc) = do sc' <- updateSC sc- return (ConCase n i a sc')- updateAlt (FnCase n a sc) = do sc' <- updateSC sc- return (FnCase n a sc')- updateAlt (ConstCase i sc) = do sc' <- updateSC sc- return (ConstCase i sc')- updateAlt (SucCase n sc) = do sc' <- updateSC sc- return (SucCase n sc')- updateAlt (DefaultCase sc) = do sc' <- updateSC sc- return (DefaultCase sc')-- update (P t n@(MN _ _) ty) = return (P t n ty)- update (P t n@(UN _) ty) = return (P t n ty)- update (P t n ty) = do (f, len) <- ST.get- (i, _) <- lift (addNameIdx n)- when (i >= len) $- ST.put (f { symbols = symbols f ++ [n] }, len+1)- return (P t (SymRef i) ty)- update (App f a) = do f' <- update f; a' <- update a- return (App f' a')- update (Bind n b sc) = do b' <- fmapMB update b- sc' <- update sc- return (Bind n b' sc')- update (Proj t i) = do t' <- update t- return (Proj t' i)- update t = return t-- ibc i (IBCDoc n) f = case lookupCtxtExact n (idris_docstrings i) of Just v -> return f { ibc_docstrings = (n,v) : ibc_docstrings f } _ -> ifail "IBC write failed"@@ -249,54 +226,65 @@ ibc i (IBCPostulate n) f = return f { ibc_postulates = n : ibc_postulates f } ibc i (IBCTotCheckErr fc err) f = return f { ibc_totcheckfail = (fc, err) : ibc_totcheckfail f } ibc i (IBCParsedRegion fc) f = return f { ibc_parsedSpan = Just fc }+ibc i (IBCModDocs n) f = case lookupCtxtExact n (idris_moduledocs i) of+ Just v -> return f { ibc_moduledocs = (n,v) : ibc_moduledocs f }+ _ -> ifail "IBC write failed" -process :: IBCFile -> FilePath -> Idris ()-process i fn- | ver i /= ibcVersion = do iLOG "ibc out of date"- ifail "Incorrect ibc version --- please rebuild"+process :: Bool -- ^ Reexporting+ -> IBCFile -> FilePath -> Idris ()+process reexp i fn+ | ver i /= ibcVersion + = do iLOG "ibc out of date"+ let e = if ver i < ibcVersion then " an earlier " else " a later "+ ifail $ "Incompatible ibc version.\nThis library was built with"+ ++ e ++ "version of Idris.\n" +++ "Please clean and rebuild."+ + --- please rebuild" | otherwise = do srcok <- runIO $ doesFileExist (sourcefile i) when srcok $ timestampOlder (sourcefile i) fn v <- verbose quiet <- getQuiet -- when (v && srcok && not quiet) $ iputStrLn $ "Skipping " ++ sourcefile i- pImportDirs (ibc_importdirs i)- pImports (ibc_imports i)- pImps (ibc_implicits i)- pFixes (ibc_fixes i)- pStatics (ibc_statics i)- pClasses (ibc_classes i)- pInstances (ibc_instances i)- pDSLs (ibc_dsls i)- pDatatypes (ibc_datatypes i)- pOptimise (ibc_optimise i)- pSyntax (ibc_syntax i)- pKeywords (ibc_keywords i)- pObjs (ibc_objs i)- pLibs (ibc_libs i)- pCGFlags (ibc_cgflags i)- pDyLibs (ibc_dynamic_libs i)- pHdrs (ibc_hdrs i)- pDefs (symbols i) (ibc_defs i)- pPatdefs (ibc_patdefs i)- pAccess (ibc_access i)- pFlags (ibc_flags i)- pFnInfo (ibc_fninfo i)- pTotal (ibc_total i)- pTotCheckErr (ibc_totcheckfail i)- pCG (ibc_cg i)- pDocs (ibc_docstrings i)- pCoercions (ibc_coercions i)- pTrans (ibc_transforms i)- pErrRev (ibc_errRev i)- pLineApps (ibc_lineapps i)- pNameHints (ibc_namehints i)- pMetaInformation (ibc_metainformation i)- pErrorHandlers (ibc_errorhandlers i)- pFunctionErrorHandlers (ibc_function_errorhandlers i)- pMetavars (ibc_metavars i)- pPostulates (ibc_postulates i)- pParsedSpan (ibc_parsedSpan i)+ pImportDirs $ force (ibc_importdirs i)+ pImports $ force (ibc_imports i)+ pImps $ force (ibc_implicits i)+ pFixes $ force (ibc_fixes i)+ pStatics $ force (ibc_statics i)+ pClasses $ force (ibc_classes i)+ pInstances $ force (ibc_instances i)+ pDSLs $ force (ibc_dsls i)+ pDatatypes $ force (ibc_datatypes i)+ pOptimise $ force (ibc_optimise i)+ pSyntax $ force (ibc_syntax i)+ pKeywords $ force (ibc_keywords i)+ pObjs $ force (ibc_objs i)+ pLibs $ force (ibc_libs i)+ pCGFlags $ force (ibc_cgflags i)+ pDyLibs $ force (ibc_dynamic_libs i)+ pHdrs $ force (ibc_hdrs i)+ pDefs reexp (symbols i) $ force (ibc_defs i)+ pPatdefs $ force (ibc_patdefs i)+ pAccess reexp $ force (ibc_access i)+ pFlags $ force (ibc_flags i)+ pFnInfo $ force (ibc_fninfo i)+ pTotal $ force (ibc_total i)+ pTotCheckErr $ force (ibc_totcheckfail i)+ pCG $ force (ibc_cg i)+ pDocs $ force (ibc_docstrings i)+ pMDocs $ force (ibc_moduledocs i)+ pCoercions $ force (ibc_coercions i)+ pTrans $ force (ibc_transforms i)+ pErrRev $ force (ibc_errRev i)+ pLineApps $ force (ibc_lineapps i)+ pNameHints $ force (ibc_namehints i)+ pMetaInformation $ force (ibc_metainformation i)+ pErrorHandlers $ force (ibc_errorhandlers i)+ pFunctionErrorHandlers $ force (ibc_function_errorhandlers i)+ pMetavars $ force (ibc_metavars i)+ pPostulates $ force (ibc_postulates i)+ pParsedSpan $ force (ibc_parsedSpan i) timestampOlder :: FilePath -> FilePath -> Idris () timestampOlder src ibc = do srct <- runIO $ getModificationTime src@@ -317,21 +305,22 @@ pImportDirs :: [FilePath] -> Idris () pImportDirs fs = mapM_ addImportDir fs -pImports :: [FilePath] -> Idris ()+pImports :: [(Bool, FilePath)] -> Idris () pImports fs- = do mapM_ (\f -> do i <- getIState+ = do mapM_ (\(re, f) -> + do i <- getIState ibcsd <- valIBCSubDir i ids <- allImportDirs fp <- findImport ids ibcsd f- if (f `elem` imported i)- then iLOG $ "Already read " ++ f- else do putIState (i { imported = f : imported i })- case fp of- LIDR fn -> do iLOG $ "Failed at " ++ fn- ifail "Must be an ibc"- IDR fn -> do iLOG $ "Failed at " ++ fn- ifail "Must be an ibc"- IBC fn src -> loadIBC fn)+-- if (f `elem` imported i)+-- then iLOG $ "Already read " ++ f+ putIState (i { imported = f : imported i })+ case fp of+ LIDR fn -> do iLOG $ "Failed at " ++ fn+ ifail "Must be an ibc"+ IDR fn -> do iLOG $ "Failed at " ++ fn+ ifail "Must be an ibc"+ IBC fn src -> loadIBC re fn) fs pImps :: [(Name, [PArg])] -> Idris ()@@ -394,7 +383,7 @@ pSyntax :: [Syntax] -> Idris () pSyntax s = do i <- getIState- putIState (i { syntax_rules = s ++ syntax_rules i })+ putIState (i { syntax_rules = updateSyntaxRules s (syntax_rules i) }) pKeywords :: [String] -> Idris () pKeywords k = do i <- getIState@@ -425,46 +414,90 @@ pPatdefs ds = mapM_ (\ (n, d) -> do i <- getIState- putIState (i { idris_patdefs = addDef n d (idris_patdefs i) }))+ putIState (i { idris_patdefs = addDef n (force d) (idris_patdefs i) })) ds -pDefs :: [Name] -> [(Name, Def)] -> Idris ()-pDefs syms ds +pDefs :: Bool -> [Name] -> [(Name, Def)] -> Idris ()+pDefs reexp syms ds = mapM_ (\ (n, d) ->- do let d' = updateDef d+ do d' <- updateDef d case d' of TyDecl _ _ -> return () _ -> do iLOG $ "SOLVING " ++ show n solveDeferred n i <- getIState -- logLvl 1 $ "Added " ++ show (n, d')- putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })) ds+ putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })+ if (not reexp) then do iLOG $ "Not exporting " ++ show n+ setAccessibility n Hidden+ else iLOG $ "Exporting " ++ show n) ds where updateDef (CaseOp c t args o s cd)- = CaseOp c t args (map updateOrig o) s (updateCD cd)- updateDef t = t+ = do o' <- mapM updateOrig o+ cd' <- updateCD cd+ return $ CaseOp c t args o' s cd'+ updateDef t = return t - updateOrig (Left t) = Left (update t)- updateOrig (Right (l, r)) = Right (update l, update r)+ updateOrig (Left t) = liftM Left (update t)+ updateOrig (Right (l, r)) = do l' <- update l+ r' <- update r+ return $ Right (l', r') updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))- = CaseDefs (ts, fmap update t)- (cs, fmap update c)- (is, fmap update i)- (rs, fmap update r)+ = do t' <- updateSC t+ c' <- updateSC c+ i' <- updateSC i+ r' <- updateSC r+ return $ CaseDefs (ts, t') (cs, c') (is, i') (rs, r') - update (P t (SymRef i) ty) = P t (syms!!i) ty- update (App f a) = App (update f) (update a)- update (Bind n b sc) = Bind n (fmap update b) (update sc)- update (Proj t i) = Proj (update t) i- update t = t+ updateSC (Case t n alts) = do alts' <- mapM updateAlt alts+ return (Case t n alts')+ updateSC (ProjCase t alts) = do alts' <- mapM updateAlt alts+ return (ProjCase t alts')+ updateSC (STerm t) = do t' <- update t+ return (STerm t')+ updateSC c = return c + updateAlt (ConCase n i ns t) = do t' <- updateSC t+ return (ConCase n i ns t')+ updateAlt (FnCase n ns t) = do t' <- updateSC t+ return (FnCase n ns t')+ updateAlt (ConstCase c t) = do t' <- updateSC t+ return (ConstCase c t')+ updateAlt (SucCase n t) = do t' <- updateSC t+ return (SucCase n t')+ updateAlt (DefaultCase t) = do t' <- updateSC t+ return (DefaultCase t')++ update (P t n ty) = do n' <- getSymbol n+ return $ P t n' ty+ update (App f a) = liftM2 App (update f) (update a)+ update (Bind n b sc) = do b' <- updateB b+ sc' <- update sc+ return $ Bind n b' sc'+ where+ updateB (Let t v) = liftM2 Let (update t) (update v)+ updateB b = do ty' <- update (binderTy b)+ return (b { binderTy = ty' })+ update (Proj t i) = do t' <- update t+ return $ Proj t' i+ update t = return t+ pDocs :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))] -> Idris ()-pDocs ds = mapM_ (\ (n, a) -> addDocStr n (fst a) (snd a)) ds+pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds -pAccess :: [(Name, Accessibility)] -> Idris ()-pAccess ds = mapM_ (\ (n, a) ->- do i <- getIState+pMDocs :: [(Name, Docstring D.DocTerm)] -> Idris ()+pMDocs ds = mapM_ addMDocStr ds+ where addMDocStr (n, d) = do ist <- getIState+ putIState ist { idris_moduledocs = addDef n d (idris_moduledocs ist) }++pAccess :: Bool -- ^ Reexporting?+ -> [(Name, Accessibility)] -> Idris ()+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 putIState (i { tt_ctxt = setAccess n a (tt_ctxt i) })) ds @@ -872,7 +905,7 @@ return (DataMI x1) 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)+ 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) = {-# SCC "putIBCFile" #-} do put x1 put x2@@ -914,6 +947,7 @@ put x38 put x39 put x40+ put x41 get = do x1 <- get@@ -957,7 +991,8 @@ x38 <- get x39 <- get x40 <- 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 <- 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) else return (initIBC { ver = x1 }) instance Binary DataOpt where@@ -1076,11 +1111,12 @@ instance Binary Plicity where put x = case x of- Imp x1 x2 x3 ->+ Imp x1 x2 x3 x4 -> do putWord8 0 put x1 put x2 put x3+ put x4 Exp x1 x2 x3 -> do putWord8 1 put x1@@ -1101,7 +1137,8 @@ 0 -> do x1 <- get x2 <- get x3 <- get- return (Imp x1 x2 x3)+ x4 <- get+ return (Imp x1 x2 x3 x4) 1 -> do x1 <- get x2 <- get x3 <- get@@ -1414,20 +1451,22 @@ PPatvar x1 x2 -> do putWord8 3 put x1 put x2- PLam x1 x2 x3 -> do putWord8 4- put x1- put x2- put x3+ PLam x1 x2 x3 x4 -> do putWord8 4+ put x1+ put x2+ put x3+ put x4 PPi x1 x2 x3 x4 -> do putWord8 5 put x1 put x2 put x3 put x4- PLet x1 x2 x3 x4 -> do putWord8 6- put x1- put x2- put x3- put x4+ PLet x1 x2 x3 x4 x5 -> do putWord8 6+ put x1+ put x2+ put x3+ put x4+ put x5 PTyped x1 x2 -> do putWord8 7 put x1 put x2@@ -1533,7 +1572,8 @@ 4 -> do x1 <- get x2 <- get x3 <- get- return (PLam x1 x2 x3)+ x4 <- get+ return (PLam x1 x2 x3 x4) 5 -> do x1 <- get x2 <- get x3 <- get@@ -1543,7 +1583,8 @@ x2 <- get x3 <- get x4 <- get- return (PLet x1 x2 x3 x4)+ x5 <- get+ return (PLet x1 x2 x3 x4 x5) 7 -> do x1 <- get x2 <- get return (PTyped x1 x2)@@ -1683,6 +1724,7 @@ DoUnify -> putWord8 22 CaseTac x1 -> do putWord8 23 put x1+ SourceFC -> putWord8 24 get = do i <- getWord8 case i of@@ -1733,6 +1775,7 @@ 22 -> return DoUnify 23 -> do x1 <- get return (CaseTac x1)+ 24 -> return SourceFC _ -> error "Corrupted binary data for PTactic'"
src/Idris/IdeSlave.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-# LANGUAGE FlexibleInstances, IncoherentInstances, PatternGuards #-} @@ -150,9 +150,9 @@ 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"+ 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
src/Idris/IdrisDoc.hs view
@@ -5,7 +5,7 @@ module Idris.IdrisDoc (generateDocs) where import Idris.Core.TT (Name (..), sUN, SpecialName (..), OutputAnnotation (..),- TextFormatting (..), txt, str, nsroot, constIsType)+ TextFormatting (..), txt, str, nsroot, constIsType, toAlist) import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc, Accessibility (..), isDConName, isFnName, isTConName)@@ -17,8 +17,9 @@ import IRTS.System (getDataFileName) +import Control.Applicative ((<|>)) import Control.Monad (forM_)-import Control.Monad.Trans.Error+import Control.Monad.Trans.Except import Control.Monad.Trans.State.Strict import Data.Maybe@@ -29,6 +30,7 @@ import qualified Data.List as L import qualified Data.List.Split as LS import qualified Data.Map as M hiding ((!))+import Data.Monoid (mempty) import qualified Data.Ord (compare) import qualified Data.Set as S import qualified Data.Text as T@@ -81,16 +83,21 @@ type Failable = Either String -- | Internal representation of a fully qualified namespace name-type NsName = [T.Text]+type NsName = [T.Text] -- | All information to be documented about a single namespace member-type NsItem = (Name, Maybe Docs, Accessibility)+type NsItem = (Name, Maybe Docs, Accessibility) +-- | Docstrings containing fully elaborated term annotations+type FullDocstring = Docstrings.Docstring Docstrings.DocTerm+ -- | All information to be documented about a namespace-type NsInfo = [NsItem]+data NsInfo = NsInfo { nsDocstring :: Maybe FullDocstring,+ nsContents :: [NsItem]+ } -- | A map from namespace names to information about them-type NsDict = M.Map NsName NsInfo+type NsDict = M.Map NsName NsInfo -- --------------------------------------------------------------- [ Utility ] @@ -142,12 +149,15 @@ fetchInfo ist nss = do let originNss = S.fromList nss info <- nsDict ist- let info' = M.map (filter filterInclude) info- info'' = M.map removeOrphans info'- info''' = M.filter (not . null) info''- reachedNss = traceNss info''' originNss S.empty- return $ M.filterWithKey (\k _ -> S.member k reachedNss) info'''-+ let accessible = M.map (filterContents filterInclude) info+ nonOrphan = M.map (updateContents removeOrphans) accessible+ nonEmpty = M.filter (not . null . nsContents) nonOrphan+ reachedNss = traceNss nonEmpty originNss S.empty+ return $ M.filterWithKey (\k _ -> S.member k reachedNss) nonEmpty+ where+ -- TODO: lensify+ filterContents p (NsInfo md ns) = NsInfo md (filter p ns)+ updateContents f x = x { nsContents = f (nsContents x) } -- | Removes loose class methods and data constructors, -- leaving them documented only under their parent.@@ -187,7 +197,7 @@ -> S.Set NsName -- ^ Set of namespaces which has been traced -> S.Set NsName -- ^ Set of namespaces to trace and all traced one traceNss nsd sT sD =- let nsTracer ns | Just nsis <- M.lookup ns nsd = map referredNss nsis+ let nsTracer ns | Just nsis <- M.lookup ns nsd = map referredNss (nsContents nsis) nsTracer _ = [S.empty] -- Ignore reached = S.unions $ concatMap nsTracer (S.toList sT) processed = S.union sT sD@@ -217,16 +227,21 @@ -- | Returns an NsDict of containing all known namespaces and their contents nsDict :: IState -> IO NsDict-nsDict ist =- let nameDefList = ctxtAlist $ tt_ctxt ist- adder m (n, _) = do map <- m- doc <- loadDocs ist n- let acc = getAccess ist n- c = [(n, doc, acc)]- return $ M.insertWith (++) (getNs n) c map- in foldl adder (return M.empty) nameDefList+nsDict ist = flip (foldl addModDoc) modDocs $ foldl adder (return M.empty) nameDefList+ where nameDefList = ctxtAlist $ tt_ctxt ist+ adder m (n, _) = do map <- m+ doc <- loadDocs ist n+ let access = getAccess ist n+ nInfo = NsInfo Nothing [(n, doc, access)]+ return $ M.insertWith addNameInfo (getNs n) nInfo map+ addNameInfo (NsInfo m ns) (NsInfo m' ns') = NsInfo (m <|> m') (ns ++ ns')+ modDocs = map (\(mn, d) -> (mn, NsInfo (Just d) [])) $ toAlist (idris_moduledocs ist)+ addModDoc :: IO NsDict -> (Name, NsInfo) -> IO NsDict+ addModDoc dict (mn, d) = fmap (M.insertWith addNameInfo (getNs mn) d) dict ++ -- | Gets the Accessibility for a Name getAccess :: IState -- ^ IState containing accessibility information -> Name -- ^ The Name to retrieve access for@@ -258,7 +273,7 @@ -> Name -- ^ Name to load Docs for -> IO (Maybe Docs) loadDocs ist n- | mayHaveDocs n = do docs <- runErrorT $ evalStateT (getDocs n) ist+ | mayHaveDocs n = do docs <- runExceptT $ evalStateT (getDocs n) ist case docs of Right d -> return (Just d) Left _ -> return Nothing | otherwise = return Nothing@@ -273,9 +288,9 @@ extractPTermNames (PRef _ n) = [n] extractPTermNames (PInferRef _ n) = [n] extractPTermNames (PPatvar _ n) = [n]-extractPTermNames (PLam n p1 p2) = n : concatMap extract [p1, p2]+extractPTermNames (PLam _ n p1 p2) = n : concatMap extract [p1, p2] extractPTermNames (PPi _ n p1 p2) = n : concatMap extract [p1, p2]-extractPTermNames (PLet n p1 p2 p3) = n : concatMap extract [p1, p2, p3]+extractPTermNames (PLet _ n p1 p2 p3) = n : concatMap extract [p1, p2, p3] extractPTermNames (PTyped p1 p2) = concatMap extract [p1, p2] extractPTermNames (PApp _ p pas) = let names = concatMap extractPArg pas in (extract p) ++ names@@ -427,11 +442,14 @@ haveDocs (_, Just d, _) = [d] haveDocs _ = [] -- We cannot do anything without a Doc- content' = concatMap haveDocs content+ content' = concatMap haveDocs (nsContents content) createDirectoryIfMissing True dir (path, h) <- openTempFile dir file BS2.hPut h $ renderHtml $ wrapper (Just ns) $ do H.h1 $ toHtml (nsName2Str ns)+ case nsDocstring content of+ Nothing -> mempty+ Just docstring -> Docstrings.renderHtml docstring H.dl ! class_ "decls" $ forM_ content' (createOtherDoc ist) hClose h renameFile path tpath@@ -590,6 +608,8 @@ H.dt $ toHtml $ show name H.dd $ Docstrings.renderHtml docstring +createOtherDoc ist (ModDoc _ docstring) = do+ Docstrings.renderHtml docstring -- | Generates everything but the actual content of the page wrapper :: Maybe NsName -- ^ Namespace name, unless it is the index
src/Idris/Imports.hs view
@@ -1,10 +1,15 @@ module Idris.Imports where +import Control.Applicative ((<$>))+import Data.List (isSuffixOf)+ import Idris.AbsSyntax import Idris.Error import Idris.Core.TT +import IRTS.System (getIdrisLibDir)+ import System.FilePath import System.Directory import Control.Monad.State.Strict@@ -12,6 +17,10 @@ data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType deriving (Show, Eq) +-- | Get the index file name for a package name+pkgIndex :: String -> FilePath+pkgIndex s = "00" ++ s ++ "-idx.ibc"+ srcPath :: FilePath -> FilePath srcPath fp = let (n, ext) = splitExtension fp in case ext of@@ -72,4 +81,23 @@ e <- doesFileExist p if e then return p else findInPath ds fp +findPkgIndex :: String -> Idris FilePath+findPkgIndex p = do let idx = pkgIndex p+ ids <- allImportDirs+ runIO $ findInPath ids idx+++installedPackages :: IO [String]+installedPackages = do+ idir <- getIdrisLibDir+ filterM (goodDir idir) =<< dirContents idir+ where+ allFilesInDir base fp = do+ let fullpath = base </> fp+ 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
src/Idris/Interactive.hs view
@@ -199,8 +199,8 @@ else iPrintResult newmv where dropCtxt 0 sc = sc dropCtxt i (PPi _ _ _ sc) = dropCtxt (i - 1) sc- dropCtxt i (PLet _ _ _ sc) = dropCtxt (i - 1) sc- dropCtxt i (PLam _ _ sc) = dropCtxt (i - 1) sc+ dropCtxt i (PLet _ _ _ _ sc) = dropCtxt (i - 1) sc+ dropCtxt i (PLam _ _ _ sc) = dropCtxt (i - 1) sc dropCtxt _ t = t stripNS tm = mapPT dens tm where@@ -299,10 +299,10 @@ where getIndent s = length (takeWhile isSpace s) appArgs skip 0 _ = ""- appArgs skip i (Bind n@(UN c) (Pi _ _) sc) + appArgs skip i (Bind n@(UN c) (Pi _ _ _) sc) | (thead c /= '_' && n `notElem` skip) = " " ++ show n ++ appArgs skip (i - 1) sc- appArgs skip i (Bind _ (Pi _ _) sc) = appArgs skip (i - 1) sc+ appArgs skip i (Bind _ (Pi _ _ _) sc) = appArgs skip (i - 1) sc appArgs skip i _ = "" stripMNBind skip (PPi b n@(UN c) ty sc) @@ -316,7 +316,7 @@ -- Make them implicit if they appear guarded by a top level constructor, -- or at the top level themselves. guessImps :: Context -> Term -> [Name]- guessImps ctxt (Bind n (Pi _ _) sc)+ guessImps ctxt (Bind n (Pi _ _ _) sc) | guarded ctxt n (substV (P Bound n Erased) sc) = n : guessImps ctxt sc | otherwise = guessImps ctxt sc@@ -328,7 +328,7 @@ isConName f ctxt = any (guarded ctxt n) args -- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows -- | thead cn /= '_' = guarded ctxt n t || guarded ctxt n sc- guarded ctxt n (Bind _ (Pi t _) sc) + guarded ctxt n (Bind _ (Pi _ t _) sc) = guarded ctxt n t || guarded ctxt n sc guarded ctxt n _ = False
src/Idris/Output.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Output where @@ -13,15 +13,20 @@ import Util.Pretty import Util.ScreenSize (getScreenWidth) -import Debug.Trace--import Control.Monad.Error (throwError)+import Control.Monad.Except (ExceptT (ExceptT), runExceptT, throwError) +import System.Console.Haskeline.MonadException + (MonadException (controlIO), RunIO (RunIO)) import System.IO (stdout, Handle, hPutStrLn) import Data.Char (isAlpha) import Data.List (nub, intersperse) import Data.Maybe (fromMaybe)++instance MonadException m => MonadException (ExceptT Err m) where+ controlIO f = ExceptT $ controlIO $ \(RunIO run) -> let+ run' = RunIO (fmap ExceptT . run . runExceptT)+ in fmap runExceptT $ f run' pshow :: IState -> Err -> String pshow ist err = displayDecorated (consoleDecorate ist) .
src/Idris/ParseExpr.hs view
@@ -23,6 +23,7 @@ import Control.Monad import Control.Monad.State.Strict +import Data.Function (on) import Data.Maybe import qualified Data.List.Split as Spl import Data.List@@ -91,13 +92,13 @@ {- | Parses a user-defined expression -} externalExpr :: SyntaxInfo -> IdrisParser PTerm externalExpr syn = do i <- get- extensions syn (syntax_rules i)+ extensions syn (syntaxRulesList $ syntax_rules i) <?> "user-defined expression" {- | Parses a simple user-defined expression -} simpleExternalExpr :: SyntaxInfo -> IdrisParser PTerm simpleExternalExpr syn = do i <- get- extensions syn (filter isSimple (syntax_rules i))+ extensions syn (filter isSimple (syntaxRulesList $ syntax_rules i)) where isSimple (Rule (Expr x:xs) _ _) = False isSimple (Rule (SimpleExpr x:xs) _ _) = False@@ -111,7 +112,7 @@ {- | Tries to parse a user-defined expression given a list of syntactic extensions -} extensions :: SyntaxInfo -> [Syntax] -> IdrisParser PTerm-extensions syn rules = choice (map (try . extension syn) (filter isValid rules))+extensions syn rules = extension syn [] (filter isValid rules) <?> "user-defined expression" where isValid :: Syntax -> Bool@@ -119,16 +120,23 @@ isValid (Rule _ _ PatternSyntax) = inPattern syn isValid (Rule _ _ TermSyntax) = not (inPattern syn) - data SynMatch = SynTm PTerm | SynBind Name -{- | Tries to parse an expression given a user-defined rule -}-extension :: SyntaxInfo -> Syntax -> IdrisParser PTerm-extension syn (Rule ssym ptm _)- = do smap <- mapM extensionSymbol ssym- let ns = mapMaybe id smap- return (flatten (update ns ptm)) -- updated with smap+extension :: SyntaxInfo -> [Maybe (Name, SynMatch)] -> [Syntax] -> IdrisParser PTerm+extension syn ns rules =+ choice $ flip map (groupBy (ruleGroup `on` syntaxSymbols) rules) $ \rs ->+ case head rs of -- can never be []+ Rule (symb:_) _ _ -> try $ do+ n <- extensionSymbol symb+ extension syn (n : ns) [Rule ss t ctx | (Rule (_:ss) t ctx) <- rs]+ -- If we have more than one Rule in this bucket, our grammar is+ -- nondeterministic.+ Rule [] ptm _ -> return (flatten (update (mapMaybe id ns) ptm)) where+ ruleGroup [] [] = True+ ruleGroup (s1:_) (s2:_) = s1 == s2+ ruleGroup _ _ = False+ extensionSymbol :: SSymbol -> IdrisParser (Maybe (Name, SynMatch)) extensionSymbol (Keyword n) = do reserved (show n); return Nothing extensionSymbol (Expr n) = do tm <- expr syn@@ -157,13 +165,13 @@ update ns (PRef fc n) = case lookup n ns of Just (SynTm t) -> t _ -> PRef fc n- update ns (PLam n ty sc)- = PLam (updateB ns n) (update ns ty) (update (dropn n ns) sc)+ update ns (PLam fc n ty sc)+ = PLam fc (updateB ns n) (update ns ty) (update (dropn n ns) sc) update ns (PPi p n ty sc) = PPi (updTacImp ns p) (updateB ns n) (update ns ty) (update (dropn n ns) sc)- update ns (PLet n ty val sc) - = PLet (updateB ns n) (update ns ty)+ update ns (PLet fc n ty val sc) + = PLet fc (updateB ns n) (update ns ty) (update ns val) (update (dropn n ns) sc) update ns (PApp fc t args) = PApp fc (update ns t) (map (fmap (update ns)) args)@@ -324,7 +332,12 @@ [pexp (PConstant (Str (show str)))]) <|> do fc <- getFC x <- fnName- return (PRef fc x)+ if inPattern syn + then option (PRef fc x)+ (do reservedOp "@"+ s <- simpleExpr syn+ return (PAs fc x s))+ else return (PRef fc x) <|> idiom syn <|> listExpr syn <|> alt syn@@ -375,7 +388,7 @@ -- No prefix operators! (bit of a hack here...) if (o == "-" || o == "!") then fail "minus not allowed in section"- else return $ PLam (sMN 1000 "ARG") Placeholder+ else return $ PLam fc (sMN 1000 "ARG") Placeholder (PApp fc (PRef fc (sUN o)) [pexp (PRef fc (sMN 1000 "ARG")), pexp e])) <|> try (do l <- simpleExpr syn@@ -385,7 +398,7 @@ fc0 <- getFC case op of Nothing -> bracketedExpr syn l- Just o -> return $ PLam (sMN 1000 "ARG") Placeholder+ Just o -> return $ PLam fc0 (sMN 1000 "ARG") Placeholder (PApp fc0 (PRef fc0 (sUN o)) [pexp l, pexp (PRef fc0 (sMN 1000 "ARG"))])) <|> do l <- expr syn@@ -519,7 +532,7 @@ args <- many (do notEndApp; arg syn) i <- get let ap = PApp fc (PRef fc (sUN "liftPrimIO"))- [pexp (PLam (sMN 0 "w")+ [pexp (PLam fc (sMN 0 "w") Placeholder (PApp fc (PRef fc (sUN "mkForeignPrim")) (fn : args ++@@ -530,7 +543,7 @@ (do try $ reservedOp "<==" fc <- getFC ff <- fnName- return (PLet (sMN 0 "match")+ return (PLet fc (sMN 0 "match") f (PMatchApp fc ff) (PRef fc (sMN 0 "match")))@@ -654,13 +667,13 @@ Left fields -> case rec of Nothing ->- return (PLam (sMN 0 "fldx") Placeholder+ return (PLam fc (sMN 0 "fldx") Placeholder (applyAll fc fields (PRef fc (sMN 0 "fldx")))) Just v -> return (applyAll fc fields v) Right fields -> case rec of Nothing ->- return (PLam (sMN 0 "fldx") Placeholder+ return (PLam fc (sMN 0 "fldx") Placeholder (getAll fc (reverse fields) (PRef fc (sMN 0 "fldx")))) Just v -> return (getAll fc (reverse fields) v)@@ -718,8 +731,7 @@ typeExpr :: SyntaxInfo -> IdrisParser PTerm typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return [] sc <- expr syn- return (bindList (PPi constraint)- (map (\x -> (sMN 0 "constrarg", x)) cs) sc)+ return (bindList (PPi constraint) cs sc) <?> "type signature" {- | Parses a lambda expression@@ -739,11 +751,12 @@ lambda :: SyntaxInfo -> IdrisParser PTerm lambda syn = do lchar '\\' <?> "lambda expression" (do xt <- try $ tyOptDeclList syn+ fc <- getFC symbol "=>" sc <- expr syn- return (bindList PLam xt sc)) <|> do+ return (bindList (PLam fc) xt sc)) <|> do ps <- sepBy (do fc <- getFC- e <- simpleExpr syn+ e <- simpleExpr (syn { inPattern = True }) return (fc, e)) (lchar ',') symbol "=>" sc <- expr syn@@ -752,7 +765,7 @@ where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm pmList [] sc = sc pmList ((i, (fc, x)) : xs) sc- = PLam (sMN i "lamp") Placeholder+ = PLam fc (sMN i "lamp") Placeholder (PCase fc (PRef fc (sMN i "lamp")) [(x, pmList xs sc)]) @@ -793,7 +806,7 @@ <?> "let binding" where buildLets [] sc = sc buildLets ((fc,PRef _ n,ty,v,[]):ls) sc- = PLet n ty v (buildLets ls sc)+ = PLet fc n ty v (buildLets ls sc) buildLets ((fc,pat,ty,v,alts):ls) sc = PCase fc v ((pat, buildLets ls sc) : alts) @@ -842,14 +855,18 @@ @ -} +bindsymbol opts st syn + = do symbol "->"+ return (Exp opts st False)+ pi :: SyntaxInfo -> IdrisParser PTerm pi syn = do opts <- piOpts syn st <- static (do xt <- try (lchar '(' *> typeDeclList syn <* lchar ')')- symbol "->"+ binder <- bindsymbol opts st syn sc <- expr syn- return (bindList (PPi (Exp opts st False)) xt sc)) <|> (do+ 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" xt <- typeDeclList syn@@ -866,16 +883,22 @@ symbol "->" sc <- expr syn return (bindList (PPi (TacImp [] Dynamic script)) xt sc))- <|> (if implicitAllowed syn then do- xt <- try (lchar '{' *> typeDeclList syn <* lchar '}')- symbol "->"- sc <- expr syn- return (bindList (PPi (Imp opts st False)) xt sc)- else do fail "no implicit arguments allowed here"))+ <|> (do xt <- try (lchar '{' *> typeDeclList syn <* lchar '}')+ symbol "->"+ cs <- constraintList syn+ sc <- expr syn+ let (im,cl)+ = if implicitAllowed syn+ then (Imp opts st False Nothing,+ constraint)+ else (Imp opts st False (Just (Impl False)),+ Imp opts st False (Just (Impl True)))+ return (bindList (PPi im) xt + (bindList (PPi cl) cs sc)))) <|> (do x <- opExpr syn- (do symbol "->"+ (do binder <- bindsymbol opts st syn sc <- expr syn- return (PPi (Exp opts st False) (sUN "__pi_arg") x sc))+ return (PPi binder (sUN "__pi_arg") x sc)) <|> return x) <?> "dependent type signature" @@ -899,18 +922,27 @@ ; @ -}-constraintList :: SyntaxInfo -> IdrisParser [PTerm]-constraintList syn = try (do lchar '('- tys <- sepBy1 (expr' (disallowImp syn)) (lchar ',')- lchar ')'- reservedOp "=>"- return tys)- <|> try (do t <- expr (disallowImp syn)- reservedOp "=>"- return [t])- <|> return []- <?> "type constraint list"+constraintList :: SyntaxInfo -> IdrisParser [(Name, PTerm)]+constraintList syn = try (constraintList1 syn)+ <|> return [] +constraintList1 :: SyntaxInfo -> IdrisParser [(Name, PTerm)]+constraintList1 syn = try (do lchar '('+ tys <- sepBy1 nexpr (lchar ',')+ lchar ')'+ reservedOp "=>"+ return tys)+ <|> try (do t <- expr (disallowImp syn)+ reservedOp "=>"+ return [(defname, t)])+ <?> "type constraint list"+ where nexpr = try (do n <- name; lchar ':'+ e <- expr' (disallowImp syn)+ return (n, e))+ <|> do e <- expr' (disallowImp syn)+ return (defname, e)+ defname = sMN 0 "constrarg"+ {- | Parses a type declaration list @ TypeDeclList ::=@@ -1121,23 +1153,29 @@ ; @ -}++constants :: [(String, Idris.Core.TT.Const)]+constants = + [ ("Integer", AType (ATInt ITBig))+ , ("Int", AType (ATInt ITNative))+ , ("Char", AType (ATInt ITChar))+ , ("Float", AType ATFloat)+ , ("String", StrType)+ , ("Ptr", PtrType)+ , ("ManagedPtr", ManagedPtrType)+ , ("prim__UnsafeBuffer", BufferType)+ , ("Bits8", AType (ATInt (ITFixed IT8)))+ , ("Bits16", AType (ATInt (ITFixed IT16)))+ , ("Bits32", AType (ATInt (ITFixed IT32)))+ , ("Bits64", AType (ATInt (ITFixed IT64)))+ , ("Bits8x16", AType (ATInt (ITVec IT8 16)))+ , ("Bits16x8", AType (ATInt (ITVec IT16 8)))+ , ("Bits32x4", AType (ATInt (ITVec IT32 4)))+ , ("Bits64x2", AType (ATInt (ITVec IT64 2)))+ ]+ constant :: IdrisParser Idris.Core.TT.Const-constant = do reserved "Integer"; return (AType (ATInt ITBig))- <|> do reserved "Int"; return (AType (ATInt ITNative))- <|> do reserved "Char"; return (AType (ATInt ITChar))- <|> do reserved "Float"; return (AType ATFloat)- <|> do reserved "String"; return StrType- <|> do reserved "Ptr"; return PtrType- <|> do reserved "ManagedPtr"; return ManagedPtrType- <|> do reserved "prim__UnsafeBuffer"; return BufferType- <|> do reserved "Bits8"; return (AType (ATInt (ITFixed IT8)))- <|> do reserved "Bits16"; return (AType (ATInt (ITFixed IT16)))- <|> do reserved "Bits32"; return (AType (ATInt (ITFixed IT32)))- <|> do reserved "Bits64"; return (AType (ATInt (ITFixed IT64)))- <|> do reserved "Bits8x16"; return (AType (ATInt (ITVec IT8 16)))- <|> do reserved "Bits16x8"; return (AType (ATInt (ITVec IT16 8)))- <|> do reserved "Bits32x4"; return (AType (ATInt (ITVec IT32 4)))- <|> do reserved "Bits64x2"; return (AType (ATInt (ITVec IT64 2)))+constant = choice [ do reserved name; return ty | (name, ty) <- constants ] <|> do f <- try float; return $ Fl f <|> do i <- natural; return $ BI i <|> do s <- verbatimStringLiteral; return $ Str s@@ -1210,115 +1248,109 @@ @ -} +-- | A specification of the arguments that tactics can take+data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n+ | ExprTArg+ | AltsTArg+ | StringLitTArg++-- The FIXMEs are Issue #1766 in the issue tracker.+-- https://github.com/idris-lang/Idris-dev/issues/1766+-- | A list of available tactics and their argument requirements+tactics :: [([String], Maybe TacticArg, SyntaxInfo -> IdrisParser PTactic)]+tactics = + [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name)+ do ns <- sepBy (spaced name) (lchar ','); return $ Intro ns)+ , noArgs ["intros"] Intros+ , (["refine"], Just ExprTArg, const $+ do n <- spaced fnName+ imps <- many imp+ return $ Refine n imps)+ , (["mrefine"], Just ExprTArg, const $+ do n <- spaced fnName+ return $ MatchRefine n)+ , expressionTactic ["rewrite"] Rewrite+ , expressionTactic ["case"] CaseTac+ , expressionTactic ["induction"] Induction+ , expressionTactic ["equiv"] Equiv+ , (["let"], Nothing, \syn -> -- FIXME syntax for let+ do n <- (indentPropHolds gtProp *> name)+ (do indentPropHolds gtProp *> lchar ':'+ ty <- indentPropHolds gtProp *> expr' syn+ indentPropHolds gtProp *> lchar '='+ t <- indentPropHolds gtProp *> expr syn+ i <- get+ return $ LetTacTy n (desugar syn i ty) (desugar syn i t))+ <|> (do indentPropHolds gtProp *> lchar '='+ t <- indentPropHolds gtProp *> expr syn+ i <- get+ return $ LetTac n (desugar syn i t)))++ , (["focus"], Just ExprTArg, const $+ do n <- spaced name+ return $ Focus n)+ , expressionTactic ["exact"] Exact+ , expressionTactic ["applyTactic"] ApplyTactic+ , expressionTactic ["byReflection"] ByReflection+ , expressionTactic ["reflect"] Reflect+ , expressionTactic ["fill"] Fill+ , (["try"], Just AltsTArg, \syn ->+ do t <- spaced (tactic syn)+ lchar '|'+ t1 <- spaced (tactic syn)+ return $ Try t t1)+ , noArgs ["compute"] Compute+ , noArgs ["trivial"] Trivial+ , noArgs ["unify"] DoUnify+ , (["search"], Nothing, const $+ do depth <- option 10 natural+ return (ProofSearch True True (fromInteger depth) Nothing []))+ , noArgs ["instance"] TCInstance+ , noArgs ["solve"] Solve+ , noArgs ["attack"] Attack+ , noArgs ["state"] ProofState+ , noArgs ["term"] ProofTerm+ , noArgs ["undo"] Undo+ , noArgs ["qed"] Qed+ , noArgs ["abandon", ":q"] Abandon+ , noArgs ["skip"] Skip+ , noArgs ["sourceLocation"] SourceFC+ , expressionTactic [":e", ":eval"] TEval+ , expressionTactic [":t", ":type"] TCheck+ , expressionTactic [":search"] TSearch+ , (["fail"], Just StringLitTArg, const $+ do msg <- stringLiteral+ return $ TFail [Idris.Core.TT.TextPart msg])+ , ([":doc"], Just ExprTArg, const $+ do whiteSpace+ doc <- (Right <$> constant) <|> (Left <$> fnName)+ eof+ return (TDocStr doc))+ ]+ where+ expressionTactic names tactic = (names, Just ExprTArg, \syn ->+ do t <- spaced (expr syn)+ i <- get+ return $ tactic (desugar syn i t))+ noArgs names tactic = (names, Nothing, const (return tactic))+ spaced parser = indentPropHolds gtProp *> parser+ imp :: IdrisParser Bool+ imp = do lchar '?'; return False+ <|> do lchar '_'; return True+ + tactic :: SyntaxInfo -> IdrisParser PTactic-tactic syn = do reserved "intro"; ns <- sepBy (indentPropHolds gtProp *> name) (lchar ',')- return $ Intro ns- <|> do reserved "intros"; return Intros- <|> try (do reserved "refine"; n <- (indentPropHolds gtProp *> fnName)- imps <- some imp- return $ Refine n imps)- <|> do reserved "refine"; n <- (indentPropHolds gtProp *> fnName)- i <- get- return $ Refine n []- <|> do reserved "mrefine"; n <- (indentPropHolds gtProp *> fnName)- i <- get- return $ MatchRefine n- <|> do reserved "rewrite"; t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ Rewrite (desugar syn i t)- <|> do reserved "case"; t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ CaseTac (desugar syn i t)- <|> do reserved "induction"; t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ Induction (desugar syn i t)- <|> do reserved "equiv"; t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ Equiv (desugar syn i t)- <|> try (do reserved "let"; n <- (indentPropHolds gtProp *> name); (indentPropHolds gtProp *> lchar ':');- ty <- (indentPropHolds gtProp *> expr' syn); (indentPropHolds gtProp *> lchar '='); t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ LetTacTy n (desugar syn i ty) (desugar syn i t))- <|> try (do reserved "let"; n <- (indentPropHolds gtProp *> name); (indentPropHolds gtProp *> lchar '=');- t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ LetTac n (desugar syn i t))- <|> do reserved "focus"; n <- (indentPropHolds gtProp *> name)- return $ Focus n- <|> do reserved "exact"; t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ Exact (desugar syn i t)- <|> do reserved "applyTactic"; t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ ApplyTactic (desugar syn i t)- <|> do reserved "byReflection"; t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ ByReflection (desugar syn i t)- <|> do reserved "reflect"; t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ Reflect (desugar syn i t)- <|> do reserved "fill"; t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ Fill (desugar syn i t)- <|> do reserved "try"; t <- (indentPropHolds gtProp *> tactic syn);- lchar '|';- t1 <- (indentPropHolds gtProp *> tactic syn)- return $ Try t t1+tactic syn = choice [ do choice (map reserved names); parser syn + | (names, _, parser) <- tactics ] <|> do lchar '{' t <- tactic syn; lchar ';'; ts <- sepBy1 (tactic syn) (lchar ';') lchar '}' return $ TSeq t (mergeSeq ts)- <|> do reserved "compute"; return Compute- <|> do reserved "trivial"; return Trivial- <|> do reserved "unify"; return DoUnify- <|> do reserved "search"- depth <- option 10 natural- return (ProofSearch True True (fromInteger depth) Nothing [])- <|> do reserved "instance"; return TCInstance- <|> do reserved "solve"; return Solve- <|> do reserved "attack"; return Attack- <|> do reserved "state"; return ProofState- <|> do reserved "term"; return ProofTerm- <|> do reserved "undo"; return Undo- <|> do reserved "qed"; return Qed- <|> do reserved "abandon"; return Abandon- <|> do reserved "skip"; return Skip- <|> do reserved "fail"- msg <- stringLiteral- return $ TFail [Idris.Core.TT.TextPart msg]- <|> do lchar ':';- ( (do reserved "q"; return Abandon)- <|> (do (reserved "e" <|> reserved "eval");- t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ TEval (desugar syn i t))- <|> (do (reserved "t" <|> reserved "type");- t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ TCheck (desugar syn i t))- <|> try (do reserved "doc"- whiteSpace- c <- constant- eof- return (TDocStr (Right c)))- <|> try (do reserved "doc"- whiteSpace- n <- fnName- eof- return (TDocStr (Left n)))- <|> try (do reserved "search"- whiteSpace- t <- (indentPropHolds gtProp *> expr syn);- i <- get- return $ TSearch (desugar syn i t))- <?> "prover command")+ <|> ((lchar ':' >> empty) <?> "prover command") <?> "tactic" where- imp :: IdrisParser Bool- imp = do lchar '?'; return False- <|> do lchar '_'; return True mergeSeq :: [PTactic] -> PTactic mergeSeq [t] = t mergeSeq (t:ts) = TSeq t (mergeSeq ts)
src/Idris/ParseHelpers.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, OverlappingInstances, StandaloneDeriving #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, StandaloneDeriving #-}+#if !(MIN_VERSION_base(4,8,0))+{-# LANGUAGE OverlappingInstances #-}+#endif module Idris.ParseHelpers where import Prelude hiding (pi)@@ -47,7 +50,11 @@ deriving instance Parsing IdrisInnerParser +#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPING #-} TokenParsing IdrisParser where+#else instance TokenParsing IdrisParser where+#endif someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure () token p = do s <- get (FC fn (sl, sc) _) <- getFC --TODO: Update after fixing getFC@@ -488,7 +495,7 @@ data IndentProperty = IndentProperty (Int -> Int -> Bool) String -- | Allows comparison of indent, and fails if property doesn't hold-indentPropHolds :: IndentProperty -> IdrisParser()+indentPropHolds :: IndentProperty -> IdrisParser () indentPropHolds (IndentProperty op msg) = do li <- lastIndent i <- indent
src/Idris/Parser.hs view
@@ -24,6 +24,7 @@ import Idris.Imports import Idris.Delaborate import Idris.Error+import Idris.Elab.Value import Idris.ElabDecls import Idris.ElabTerm import Idris.Coverage@@ -49,7 +50,7 @@ import Control.Applicative hiding (Const) import Control.Monad-import Control.Monad.Error (throwError, catchError)+import Control.Monad.Except (throwError, catchError) import Control.Monad.State.Strict import Data.Function@@ -90,18 +91,21 @@ ModuleHeader ::= 'module' Identifier_t ';'?; @ -}-moduleHeader :: IdrisParser [String]-moduleHeader = try (do noDocCommentHere "Modules cannot have documentation comments"+moduleHeader :: IdrisParser (Maybe (Docstring ()), [String])+moduleHeader = try (do docs <- optional docComment+ noArgs docs reserved "module" i <- identifier option ';' (lchar ';')- return (moduleName i))+ return (fmap fst docs, moduleName i)) <|> try (do lchar '%'; reserved "unqualified"- return [])- <|> return (moduleName "Main")+ return (Nothing, []))+ <|> return (Nothing, moduleName "Main") where moduleName x = case span (/='.') x of (x, "") -> [x] (x, '.':y) -> x : moduleName y+ noArgs (Just (_, args)) | not (null args) = fail "Modules do not take arguments"+ noArgs _ = return () {- | Parses an import statement @@ -109,13 +113,14 @@ Import ::= 'import' Identifier_t ';'?; @ -}-import_ :: IdrisParser (String, Maybe String, FC)+import_ :: IdrisParser (Bool, String, Maybe String, FC) import_ = do fc <- getFC reserved "import"+ reexport <- option False (do reserved "public"; return True) id <- identifier newName <- optional (reserved "as" *> identifier) option ';' (lchar ';')- return (toPath id, toPath <$> newName, fc)+ return (reexport, toPath id, toPath <$> newName, fc) <?> "import statement" where toPath = foldl1' (</>) . Spl.splitOn "." @@ -223,7 +228,7 @@ -- | Extend an 'IState' with a new syntax extension. See also 'addReplSyntax'. addSyntax :: IState -> Syntax -> IState-addSyntax i s = i { syntax_rules = s : rs,+addSyntax i s = i { syntax_rules = updateSyntaxRules [s] rs, syntax_keywords = ks ++ ns, ibc_write = IBCSyntax s : map IBCKeyword ks ++ ibc } where rs = syntax_rules i@@ -233,7 +238,7 @@ -- | Like 'addSyntax', but no effect on the IBC. addReplSyntax :: IState -> Syntax -> IState-addReplSyntax i s = i { syntax_rules = s : rs,+addReplSyntax i s = i { syntax_rules = updateSyntaxRules [s] rs, syntax_keywords = ks ++ ns } where rs = syntax_rules i ns = syntax_keywords i@@ -639,8 +644,7 @@ cn <- fnName args <- many (simpleExpr syn) let sc = PApp fc (PRef fc cn) (map pexp args)- let t = bindList (PPi constraint)- (map (\x -> (sMN 0 "constraint", x)) cs) sc+ let t = bindList (PPi constraint) cs sc ds <- option [] (instanceBlock syn) return [PInstance syn fc cs cn args t en ds] <?> "instance declaration"@@ -757,10 +761,11 @@ rhs :: SyntaxInfo -> Name -> IdrisParser PTerm rhs syn n = do lchar '='; expr syn <|> do symbol "?=";+ fc <- getFC name <- option n' (do symbol "{"; n <- fnName; symbol "}"; return n) r <- expr syn- return (addLet name r)+ return (addLet fc name r) <|> do reserved "impossible"; return PImpossible <?> "function right hand side" where mkN :: Name -> Name@@ -770,11 +775,11 @@ mkN (NS x n) = NS (mkN x) n n' :: Name n' = mkN n- addLet :: Name -> PTerm -> PTerm- addLet nm (PLet n ty val r) = PLet n ty val (addLet nm r)- addLet nm (PCase fc t cs) = PCase fc t (map addLetC cs)- where addLetC (l, r) = (l, addLet nm r)- addLet nm r = (PLet (sUN "value") Placeholder r (PMetavar nm))+ addLet :: FC -> Name -> PTerm -> PTerm+ addLet fc nm (PLet fc' n ty val r) = PLet fc' n ty val (addLet fc nm r)+ addLet fc nm (PCase fc' t cs) = PCase fc' t (map addLetC cs)+ where addLetC (l, r) = (l, addLet fc nm r)+ addLet fc nm r = (PLet fc (sUN "value") Placeholder r (PMetavar nm)) {- |Parses a function clause @@ -840,7 +845,7 @@ return x, do terminator return ([], [])]- let capp = PLet (sMN 0 "match")+ let capp = PLet fc (sMN 0 "match") ty (PMatchApp fc n) (PRef fc (sMN 0 "match"))@@ -933,7 +938,7 @@ -} wExpr :: SyntaxInfo -> IdrisParser PTerm wExpr syn = do lchar '|'- expr' syn+ expr' (syn { inPattern = True }) <?> "with pattern" {- | Parses a where block@@ -1132,24 +1137,24 @@ parseTactic st = runparser (fullTactic defaultSyntax) st "(input)" -- | Parse module header and imports-parseImports :: FilePath -> String -> Idris ([String], [(String, Maybe String, FC)], Maybe Delta)+parseImports :: FilePath -> String -> Idris (Maybe (Docstring ()), [String], [(Bool, String, Maybe String, FC)], Maybe Delta) parseImports fname input = do i <- getIState case parseString (runInnerParser (evalStateT imports i)) (Directed (UTF8.fromString fname) 0 0 0 0) input of Failure err -> fail (show err) Success (x, i) -> do putIState i return x- where imports :: IdrisParser (([String], [(String, Maybe String, FC)], Maybe Delta), IState)+ where imports :: IdrisParser ((Maybe (Docstring ()), [String], [(Bool, String, Maybe String, FC)], Maybe Delta), IState) imports = do whiteSpace- mname <- moduleHeader- ps <- many import_- mrk <- mark- isEof <- lookAheadMatches eof+ (mdoc, mname) <- moduleHeader+ ps <- many import_+ mrk <- mark+ isEof <- lookAheadMatches eof let mrk' = if isEof then Nothing else Just mrk i <- get- return ((mname, ps, mrk'), i)+ return ((mdoc, mname, ps, mrk'), i) -- | There should be a better way of doing this... findFC :: Doc -> (FC, String)@@ -1196,13 +1201,13 @@ return (ds, i') {- | Load idris module and show error if something wrong happens -}-loadModule :: FilePath -> Idris String+loadModule :: FilePath -> Idris (Maybe String) loadModule f- = idrisCatch (loadModule' f)+ = idrisCatch (fmap Just (loadModule' f)) (\e -> do setErrSpan (getErrSpan e) ist <- getIState iWarn (getErrSpan e) $ pprintErr ist e- return "")+ return Nothing) {- | Load idris module -} loadModule' :: FilePath -> Idris String@@ -1219,7 +1224,7 @@ IDR fn -> loadSource False fn Nothing LIDR fn -> loadSource True fn Nothing IBC fn src ->- idrisCatch (loadIBC fn)+ idrisCatch (loadIBC True fn) (\c -> do iLOG $ fn ++ " failed " ++ pshow i c case src of IDR sfn -> loadSource False sfn Nothing@@ -1229,18 +1234,18 @@ {- | Load idris code from file -}-loadFromIFile :: IFileType -> Maybe Int -> Idris ()-loadFromIFile i@(IBC fn src) maxline+loadFromIFile :: Bool -> IFileType -> Maybe Int -> Idris ()+loadFromIFile reexp i@(IBC fn src) maxline = do iLOG $ "Skipping " ++ getSrcFile i- idrisCatch (loadIBC fn)+ idrisCatch (loadIBC reexp fn) (\err -> ierror $ LoadingFailed fn err) where getSrcFile (IDR fn) = fn getSrcFile (LIDR fn) = fn getSrcFile (IBC f src) = getSrcFile src -loadFromIFile (IDR fn) maxline = loadSource' False fn maxline-loadFromIFile (LIDR fn) maxline = loadSource' True fn maxline+loadFromIFile _ (IDR fn) maxline = loadSource' False fn maxline+loadFromIFile _ (LIDR fn) maxline = loadSource' True fn maxline {-| Load idris source code and show error if something wrong happens -} loadSource' :: Bool -> FilePath -> Maybe Int -> Idris ()@@ -1260,24 +1265,25 @@ let def_total = default_total i file_in <- runIO $ readFile f file <- if lidr then tclift $ unlit f file_in else return file_in- (mname, imports_in, pos) <- parseImports f file+ (mdocs, mname, imports_in, pos) <- parseImports f file ai <- getAutoImports- let imports = map (\n -> (n, Just n, emptyFC)) ai ++ imports_in+ let imports = map (\n -> (True, n, Just n, emptyFC)) ai ++ imports_in ids <- allImportDirs ibcsd <- valIBCSubDir i- mapM_ (\f -> do fp <- findImport ids ibcsd f+ mapM_ (\(re, f) -> + do fp <- findImport ids ibcsd f case fp of LIDR fn -> ifail $ "No ibc for " ++ f IDR fn -> ifail $ "No ibc for " ++ f- IBC fn src -> loadIBC fn)- [fn | (fn, _, _) <- imports]+ IBC fn src -> loadIBC True fn)+ [(re, fn) | (re, fn, _, _) <- imports] reportParserWarnings -- process and check module aliases let modAliases = M.fromList- [(prep alias, prep realName) | (realName, Just alias, fc) <- imports]+ [(prep alias, prep realName) | (reexport, realName, Just alias, fc) <- imports] prep = map T.pack . reverse . Spl.splitOn "/"- aliasNames = [(alias, fc) | (_, Just alias, fc) <- imports]+ aliasNames = [(alias, fc) | (_, _, Just alias, fc) <- imports] histogram = groupBy ((==) `on` fst) . sortBy (comparing fst) $ aliasNames case map head . filter ((/= 1) . length) $ histogram of [] -> logLvl 3 $ "Module aliases: " ++ show (M.toList modAliases)@@ -1289,7 +1295,7 @@ -- record package info in .ibc imps <- allImportDirs mapM_ addIBC (map IBCImportDir imps)- mapM_ (addIBC . IBCImport) [realName | (realName, alias, fc) <- imports]+ mapM_ (addIBC . IBCImport) [(reexport, realName) | (reexport, realName, alias, fc) <- imports] let syntax = defaultSyntax{ syn_namespace = reverse mname, maxline = toline } ds' <- parseProg syntax f file pos@@ -1338,6 +1344,13 @@ i <- getIState addHides (hide_list i) + -- Save module documentation if applicable+ i <- getIState+ case mdocs of+ Nothing -> return ()+ Just docs -> addModDoc syntax mname docs++ -- Finally, write an ibc if checking was successful ok <- noErrors when ok $@@ -1361,6 +1374,17 @@ PClass _ _ _ _ _ _ _ _ -> r PInstance _ _ _ _ _ _ _ _ -> r _ -> x++ addModDoc :: SyntaxInfo -> [String] -> Docstring () -> Idris ()+ addModDoc syn mname docs =+ do ist <- getIState+ docs' <- elabDocTerms recinfo (parsedDocs ist)+ let modDocs' = addDef docName docs' (idris_moduledocs ist)+ putIState ist { idris_moduledocs = modDocs' }+ addIBC (IBCModDocs docName)+ where+ docName = NS modDocName (map T.pack (reverse mname))+ parsedDocs ist = annotCode (tryFullExpr syn ist) docs {- | Adds names to hide list -} addHides :: [(Name, Maybe Accessibility)] -> Idris ()
src/Idris/PartialEval.hs view
@@ -66,6 +66,8 @@ do when (length tms == 1) $ checkProgress ns reductions return (Right (lhs, rhs')) + -- TMP HACK until I do PE by WHNF rather than using main evaluator+ toLimit (n, Nothing) | isTCDict n ctxt = (n, 2) toLimit (n, Nothing) = (n, 65536) -- somewhat arbitrary reduction limit toLimit (n, Just l) = (n, l) @@ -83,35 +85,35 @@ where -- Specialise static argument in type by let-binding provided value instead -- of expecting it as a function argument- st ((ExplicitS, v) : xs) (Bind n (Pi t _) sc)+ st ((ExplicitS, v) : xs) (Bind n (Pi _ t _) sc) = Bind n (Let t v) (st xs sc)- st ((ImplicitS, v) : xs) (Bind n (Pi t _) sc)+ st ((ImplicitS, v) : xs) (Bind n (Pi _ t _) sc) = Bind n (Let t v) (st xs sc) -- Erase argument from function type- st ((UnifiedD, _) : xs) (Bind n (Pi t _) sc)+ st ((UnifiedD, _) : xs) (Bind n (Pi _ t _) sc) = st xs sc -- Keep types as is- st (_ : xs) (Bind n (Pi t k) sc)- = Bind n (Pi t k) (st xs sc)+ st (_ : xs) (Bind n (Pi i t k) sc)+ = Bind n (Pi i t k) (st xs sc) st _ t = t -- Erase implicit dynamic argument if existing argument shares it value, -- by substituting the value of previous argument- unifyEq (imp@(ImplicitD, v) : xs) (Bind n (Pi t k) sc)+ unifyEq (imp@(ImplicitD, v) : xs) (Bind n (Pi i t k) sc) = do amap <- get case lookup imp amap of Just n' -> do put (amap ++ [((UnifiedD, Erased), n)]) sc' <- unifyEq xs (subst n (P Bound n' Erased) sc)- return (Bind n (Pi t k) sc') -- erase later+ return (Bind n (Pi i t k) sc') -- erase later _ -> do put (amap ++ [(imp, n)]) sc' <- unifyEq xs sc- return (Bind n (Pi t k) sc')- unifyEq (x : xs) (Bind n (Pi t k) sc)+ return (Bind n (Pi i t k) sc')+ unifyEq (x : xs) (Bind n (Pi i t k) sc) = do args <- get put (args ++ [(x, n)]) sc' <- unifyEq xs sc- return (Bind n (Pi t k) sc')+ return (Bind n (Pi i t k) sc') unifyEq xs t = do args <- get put (args ++ (zip xs (repeat (sUN "_")))) return t@@ -125,9 +127,9 @@ mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm mkPE_TyDecl ist args ty = mkty args ty where- mkty ((ExplicitD, v) : xs) (Bind n (Pi t k) sc)+ mkty ((ExplicitD, v) : xs) (Bind n (Pi _ t k) sc) = PPi expl n (delab ist (generaliseIn t)) (mkty xs sc)- mkty ((ImplicitD, v) : xs) (Bind n (Pi t k) sc)+ mkty ((ImplicitD, v) : xs) (Bind n (Pi _ t k) sc) | concreteClass ist t = mkty xs sc | classConstraint ist t = PPi constraint n (delab ist (generaliseIn t)) (mkty xs sc)
src/Idris/Primitives.hs view
@@ -20,13 +20,13 @@ p_type :: Type, p_arity :: Int, p_def :: [Const] -> Maybe Const,- p_lexp :: (Int, PrimFn),+ p_lexp :: (Int, PrimFn), p_total :: Totality } ty :: [Const] -> Const -> Type ty [] x = Constant x-ty (t:ts) x = Bind (sMN 0 "T") (Pi (Constant t) (TType (UVar (-3)))) (ty ts x)+ty (t:ts) x = Bind (sMN 0 "T") (Pi Nothing (Constant t) (TType (UVar (-3)))) (ty ts x) total, partial, iopartial :: Totality total = Total []
src/Idris/ProofSearch.hs view
@@ -38,20 +38,22 @@ (tryAll xs) True else tryAll xs -cantSolveGoal :: ElabD ()+cantSolveGoal :: ElabD a cantSolveGoal = do g <- goal env <- get_env lift $ tfail $ CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env) -proofSearch :: Bool -> +proofSearch :: Bool -> -- recursive search (False for 'refine') Bool -> -- invoked from a tactic proof. If so, making -- new metavariables is meaningless, and there shoudl -- be an error reported instead.+ Bool -> -- ambiguity ok+ Bool -> -- defer on failure Int -> -- maximum depth (PTerm -> ElabD ()) -> Maybe Name -> Name -> [Name] -> IState -> ElabD ()-proofSearch False fromProver depth elab _ nroot [fn] ist+proofSearch False fromProver ambigok deferonfail depth elab _ nroot [fn] ist = do -- get all possible versions of the name, take the first one that -- works let all_imps = lookupCtxtName fn (idris_implicits ist)@@ -82,13 +84,45 @@ isImp (PImp p _ _ _ _) = (True, p) isImp arg = (True, priority arg) -- try to get all of them by unification-proofSearch rec fromProver maxDepth elab fn nroot hints ist - = case lookupCtxt nroot (idris_tyinfodata ist) of- [TISolution ts] -> findInferredTy ts- _ -> psRec rec maxDepth+proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist + = do compute+ ty <- goal+ argsok <- conArgsOK ty+ if ambigok || argsok then+ case lookupCtxt nroot (idris_tyinfodata ist) of+ [TISolution ts] -> findInferredTy ts+ _ -> psRec rec maxDepth+ else autoArg (sUN "auto") -- not enough info in the type yet where findInferredTy (t : _) = elab (delab ist (toUN t)) + conArgsOK ty+ = let (f, as) = unApply ty in+ case f of+ P _ n _ -> case lookupCtxt n (idris_datatypes ist) of+ [t] -> do rs <- mapM (conReady as) (con_names t)+ return (and rs)+ _ -> fail "Ambiguous name"+ TType _ -> return True+ _ -> fail "Not a data type"++ conReady :: [Term] -> Name -> ElabD Bool+ conReady as n + = case lookupTyExact n (tt_ctxt ist) of+ Just ty -> do let (_, cs) = unApply (getRetTy ty)+ -- if any metavariables in 'as' correspond to+ -- a constructor form in 'cs', then we're not+ -- ready to run auto yet. Otherwise, go for it+ hs <- get_holes+ return $ and (map (notHole hs) (zip as cs))+ Nothing -> fail "Can't happen"++ 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+ toUN t@(P nt (MN i n) ty) | ('_':xs) <- str n = t | otherwise = P nt (UN n) ty@@ -140,8 +174,9 @@ (psRec True d) "proof search local apply" -- Like type class resolution, but searching with constructors- tryCon d n =- do let imps = case lookupCtxtName n (idris_implicits ist) of+ tryCon d n = + do ty <- goal+ let imps = case lookupCtxtName n (idris_implicits ist) of [] -> [] [args] -> map isImp (snd args) _ -> fail "Ambiguous name"@@ -153,6 +188,7 @@ hs' <- get_holes when (length ps < length ps') $ fail "Can't apply constructor" mapM_ (\ (_, h) -> do focus h+ aty <- goal psRec True d) (filter (\ (x, y) -> not x) (zip (map fst imps) args)) solve
src/Idris/Prover.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PatternGuards #-} module Idris.Prover where import Idris.Core.Elaborate hiding (Tactic(..))@@ -52,10 +53,10 @@ where bird = if lit then "> " else "" break = "\n" ++ bird -proverSettings :: ElabState [PDecl] -> Settings Idris+proverSettings :: ElabState EState -> Settings Idris proverSettings e = setComplete (proverCompletion (assumptionNames e)) defaultSettings -assumptionNames :: ElabState [PDecl] -> [String]+assumptionNames :: ElabState EState -> [String] assumptionNames e = case envAtFocus (proof e) of OK env -> names env@@ -67,7 +68,7 @@ prove opt ctxt lit n ty = do let ps = initElaborator n ctxt ty ideslavePutSExp "start-proof-mode" n- (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, []) "" Nothing) Nothing+ (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, initEState) "" Nothing) Nothing iLOG $ "Adding " ++ show tm i <- getIState case idris_outputmode i of@@ -75,7 +76,7 @@ _ -> iputStrLn $ showProof lit n prf let proofs = proof_list i putIState (i { proof_list = (n, prf) : proofs })- let tree = simpleCase False True False CompileTime (fileFC "proof") [] [] [([], P Ref n ty, tm)]+ 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 logLvl 5 ("Proof type: " ++ show pty ++ "\n" ++@@ -85,7 +86,7 @@ Error e -> ierror (CantUnify False ty pty e [] 0) ptm' <- applyOpts ptm ei <- getErasureInfo `fmap` getIState- updateContext (addCasedef n ei (CaseInfo True False) False False True False+ updateContext (addCasedef n ei (CaseInfo True False) False (STerm Erased) True False [] [] -- argtys, inaccArgs [Right (P Ref n ty, ptm)] [([], P Ref n ty, ptm)]@@ -98,7 +99,7 @@ runIO . hPutStrLn h $ IdeSlave.convSExp "return" (IdeSlave.SymbolAtom "ok", "") n _ -> return () -elabStep :: ElabState [PDecl] -> ElabD a -> Idris (a, ElabState [PDecl])+elabStep :: ElabState EState -> ElabD a -> Idris (a, ElabState EState) elabStep st e = case runStateT eCheck st of OK (a, st') -> return (a, st') Error a -> ierror a@@ -111,13 +112,14 @@ ctxt <- get_context lift $ check ctxt [] (forget tm) return res- ((_,_,_,e,_,_):_) -> lift $ Error e+ ((_,_,_,_,e,_,_):_) -> lift $ Error e dumpState :: IState -> ProofState -> Idris ()-dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =- do rendered <- iRender $ prettyName True False [] nm <> colon <+> text "No more goals."+dumpState ist ps | [] <- holes ps =+ do let nm = thname ps+ rendered <- iRender $ prettyName True False [] nm <> colon <+> text "No more goals." iputGoal rendered-dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _ _) = do+dumpState ist ps | (h : hs) <- holes ps = do let OK ty = goalAtFocus ps let OK env = envAtFocus ps let state = prettyOtherGoals hs <> line <>@@ -127,6 +129,8 @@ iputGoal rendered where+ (h : hs) = holes ps -- apparently the pattern guards don't give us this+ ppo = ppOptionIst ist tPretty bnd t = annotate (AnnTerm bnd t) .@@ -173,11 +177,11 @@ freeEnvNames :: Env -> [Name] freeEnvNames = foldl (++) [] . map (\(n, b) -> freeNames (Bind n b Erased)) -lifte :: ElabState [PDecl] -> ElabD a -> Idris a+lifte :: ElabState EState -> ElabD a -> Idris a lifte st e = do (v, _) <- elabStep st e return v -receiveInput :: Handle -> ElabState [PDecl] -> Idris (Maybe String)+receiveInput :: Handle -> ElabState EState -> Idris (Maybe String) receiveInput h e = do i <- getIState let inh = if h == stdout then stdin else h@@ -201,7 +205,7 @@ Just (IdeSlave.DocsFor str) -> return (Just (":doc " ++ str)) _ -> return Nothing -ploop :: Name -> Bool -> String -> [String] -> ElabState [PDecl] -> Maybe History -> Idris (Term, [String])+ploop :: Name -> Bool -> String -> [String] -> ElabState EState -> Maybe History -> Idris (Term, [String]) ploop fn d prompt prf e h = do i <- getIState let autoSolve = opt_autoSolve (idris_options i)@@ -245,9 +249,10 @@ Success (TEval t) -> evalTerm t e Success (TDocStr x) -> docStr x Success (TSearch t) -> search t- Success tac -> do (_, e) <- elabStep e saveState- (_, st) <- elabStep e (runTac autoSolve i fn tac)- return (True, st, False, prf ++ [step], Right $ iPrintResult ""))+ Success tac ->+ do (_, e) <- elabStep e saveState+ (_, 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') case res of@@ -300,6 +305,8 @@ return (False, e, False, prf, Right action)) (\err -> do putIState ist { tt_ctxt = ctxt } ; ierror err) + proverFC = FC "(prover shell)" (0, 0) (0, 0)+ evalTerm t e = withErrorReflection $ do ctxt <- getContext ist <- getIState@@ -320,7 +327,7 @@ putIState ist return (False, e, False, prf, Right action)) (\err -> do putIState ist ; ierror err)- docStr :: Either Name Const -> Idris (Bool, ElabState [PDecl], Bool, [String], Either Err (Idris ()))+ docStr :: Either Name Const -> Idris (Bool, ElabState EState, Bool, [String], Either Err (Idris ())) docStr (Left n) = do ist <- getIState idrisCatch (case lookupCtxtName n (idris_docstrings ist) of [] -> return (False, e, False, prf,@@ -333,4 +340,4 @@ return $ pprintDocs ist doc docStr (Right c) = do ist <- getIState return (False, e, False, prf, Right . iRenderResult $ pprintConstDocs ist c (constDocs c))- search t = return (False, e, False, prf, Right $ searchByType t)+ search t = return (False, e, False, prf, Right $ searchByType [] t)
src/Idris/REPL.hs view
@@ -5,7 +5,7 @@ import Idris.AbsSyntax import Idris.ASTUtils-import Idris.Apropos (apropos)+import Idris.Apropos (apropos, aproposModules) import Idris.REPLParser import Idris.ElabDecls import Idris.ElabTerm@@ -13,14 +13,14 @@ import Idris.Error import Idris.ErrReverse import Idris.Delaborate-import Idris.Docstrings (Docstring, overview, renderDocstring)+import Idris.Docstrings (Docstring, overview, renderDocstring, renderDocTerm)+import Idris.Help import Idris.IdrisDoc import Idris.Prover import Idris.Parser hiding (indent) import Idris.Primitives import Idris.Coverage import Idris.Docs hiding (Doc)-import Idris.Help import Idris.Completion import qualified Idris.IdeSlave as IdeSlave import Idris.Chaser@@ -33,6 +33,7 @@ import Idris.Interactive import Idris.WhoCalls import Idris.TypeSearch (searchByType)+import Idris.IBC (loadPkgIndex, writePkgIndex) import Idris.Elab.Type import Idris.Elab.Clause@@ -48,6 +49,7 @@ import Idris.Core.Evaluate import Idris.Core.Execute (execute) import Idris.Core.TT+import Idris.Core.Unify import Idris.Core.Constraints import IRTS.Compiler@@ -74,7 +76,7 @@ import System.Directory import System.IO import Control.Monad-import Control.Monad.Trans.Error (ErrorT(..))+import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.State.Strict ( StateT, execStateT, evalStateT, get, put ) import Control.Monad.Trans ( lift ) import Control.Concurrent.MVar@@ -95,8 +97,9 @@ -- | Run the REPL repl :: IState -- ^ The initial state -> [FilePath] -- ^ The loaded modules+ -> FilePath -- ^ The file to edit (with :e) -> InputT Idris ()-repl orig mods+repl orig mods efile = -- H.catch do let quiet = opt_quiet (idris_options orig) i <- lift getIState@@ -114,10 +117,13 @@ Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye") return () Just input -> -- H.catch- do ms <- H.catch (lift $ processInput input orig mods)+ do ms <- H.catch (lift $ processInput input orig mods efile) (ctrlC (return (Just mods))) case ms of- Just mods -> repl orig mods+ Just mods -> let efile' = case mods of+ [] -> efile+ (e:_) -> e in+ repl orig mods efile' Nothing -> return () -- ctrlC) -- ctrlC@@ -140,7 +146,7 @@ showM c thm n = if c then colouriseFun thm (show n) else show n --- | Run the REPL seDver+-- | Run the REPL server startServer :: PortID -> IState -> [FilePath] -> Idris () startServer port orig fn_in = do tid <- runIO $ forkOS (serverLoop port) return ()@@ -168,7 +174,7 @@ processNetCmd orig i h fn cmd = do res <- case parseCmd i "(net)" cmd of Failure err -> return (Left (Msg " invalid command"))- Success (Right c) -> runErrorT $ evalStateT (processNet fn c) i+ Success (Right c) -> runExceptT $ evalStateT (processNet fn c) i Success (Left err) -> return (Left (Msg err)) case res of Right x -> return x@@ -307,8 +313,8 @@ clearErr putIState (orig { idris_options = idris_options i, idris_outputmode = (IdeSlave id h) })- loadInputs [filename] toline- isetPrompt (mkPrompt [filename])+ mods <- loadInputs [filename] toline+ isetPrompt (mkPrompt mods) -- Report either success or failure i <- getIState case (errSpan i) of@@ -319,17 +325,12 @@ (idris_parsedSpan i) in runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id Just x -> iPrintError $ "didn't load " ++ filename- ideslave h orig [filename]+ ideslave h orig mods runIdeSlaveCommand h id orig fn mods (IdeSlave.TypeOf name) = case splitName name of Left err -> iPrintError err Right n -> process "(ideslave)" (Check (PRef (FC "(ideslave)" (0,0) (0,0)) n))- where splitName :: String -> Either String Name- splitName s = case reverse $ splitOn "." s of- [] -> Left ("Didn't understand name '" ++ s ++ "'")- [n] -> Right $ sUN n- (n:ns) -> Right $ sNS (sUN n) ns runIdeSlaveCommand h id orig fn mods (IdeSlave.DocsFor name) = case parseConst orig name of Success c -> process "(ideslave)" (DocStr (Right c))@@ -354,7 +355,7 @@ Left err -> iPrintError err Right n -> process fn (MakeLemma False line n) runIdeSlaveCommand h id orig fn mods (IdeSlave.Apropos a) =- process fn (Apropos a)+ process fn (Apropos [] a) runIdeSlaveCommand h id orig fn mods (IdeSlave.GetOpts) = do ist <- getIState let opts = idris_options ist@@ -396,7 +397,7 @@ -- | Split a function type into a pair of premises, conclusion. -- Each maintains both the original and delaborated versions. splitPi :: IState -> Type -> ([(Name, Type, PTerm)], Type, PTerm)- splitPi ist (Bind n (Pi t _) rest) =+ splitPi ist (Bind n (Pi _ t _) rest) = let (hs, c, pc) = splitPi ist rest in ((n, t, delabTy' ist [] t False False):hs, c, delabTy' ist [] c False False)@@ -481,11 +482,6 @@ case splitName name of Left err -> iPrintError err Right n -> process "(ideslave)" (PrintDef n)- where splitName :: String -> Either String Name- splitName s = case reverse $ splitOn "." s of- [] -> Left ("Didn't understand name '" ++ s ++ "'")- [n] -> Right $ sUN n- (n:ns) -> Right $ sNS (sUN n) ns runIdeSlaveCommand h id orig fn modes (IdeSlave.ErrString e) = do ist <- getIState let out = displayS . renderPretty 1.0 60 $ pprintErr ist e@@ -517,8 +513,11 @@ splitName :: String -> Either String Name splitName s = case reverse $ splitOn "." s of [] -> Left ("Didn't understand name '" ++ s ++ "'")- [n] -> Right $ sUN n- (n:ns) -> Right $ sNS (sUN n) ns+ [n] -> Right . sUN $ unparen n+ (n:ns) -> Right $ sNS (sUN (unparen n)) ns+ where unparen "" = ""+ unparen ('(':x:xs) | last xs == ')' = init (x:xs)+ unparen str = str ideslaveProcess :: FilePath -> Command -> Idris () ideslaveProcess fn Warranty = process fn Warranty@@ -539,7 +538,7 @@ ideslaveProcess fn (TotCheck n) = process fn (TotCheck n) ideslaveProcess fn (DebugInfo n) = do process fn (DebugInfo n) iPrintResult ""-ideslaveProcess fn (Search t) = process fn (Search t)+ideslaveProcess fn (Search ps t) = process fn (Search ps t) ideslaveProcess fn (Spec t) = process fn (Spec t) -- RmProof and AddProof not supported! ideslaveProcess fn (ShowProof n') = process fn (ShowProof n')@@ -582,8 +581,8 @@ 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) iPrintResult ""-ideslaveProcess fn (Apropos a) = do process fn (Apropos a)- 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)@@ -602,8 +601,8 @@ _ -> False processInput :: String ->- IState -> [FilePath] -> Idris (Maybe [FilePath])-processInput cmd orig inputs+ IState -> [FilePath] -> FilePath -> Idris (Maybe [FilePath])+processInput cmd orig inputs efile = do i <- getIState let opts = idris_options i let quiet = opt_quiet opts@@ -620,20 +619,20 @@ } clearErr mods <- loadInputs inputs Nothing- return (Just inputs)+ return (Just mods) Success (Right (Load f toline)) -> do putIState orig { idris_options = idris_options i , idris_colourTheme = idris_colourTheme i } clearErr mod <- loadInputs [f] toline- return (Just [f])+ return (Just mod) Success (Right (ModImport f)) -> do clearErr fmod <- loadModule f- return (Just (inputs ++ [fmod]))+ return (Just (inputs ++ maybe [] (:[]) fmod)) Success (Right Edit) -> do -- takeMVar stvar- edit fn orig+ edit efile orig return (Just inputs) Success (Right Proofs) -> do proofs orig return (Just inputs)@@ -669,10 +668,10 @@ env <- runIO $ getEnvironment let editor = getEditor env let line = case errSpan i of- Just l -> " +" ++ show (fst (fc_start l)) ++ " "- Nothing -> " "- let cmd = editor ++ line ++ fixName f- runIO $ system cmd+ Just l -> ['+' : show (fst (fc_start l))]+ Nothing -> []+ let args = line ++ [fixName f]+ runIO $ rawSystem editor args clearErr putIState $ orig { idris_options = idris_options i , idris_colourTheme = idris_colourTheme i@@ -881,12 +880,17 @@ process fn (DocStr (Left n)) = do ist <- getIState- case lookupCtxtName n (idris_docstrings ist) of+ let docs = lookupCtxtName n (idris_docstrings 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 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)) = do ist <- getIState@@ -929,6 +933,13 @@ map (\(n, t) -> showN n ++ " is " ++ showTotal t i) $ ts +process fn (DebugUnify l r)+ = do (ltm, _) <- elabVal recinfo ERHS l+ (rtm, _) <- elabVal recinfo ERHS r+ ctxt <- getContext+ case unify ctxt [] ltm rtm [] [] [] [] of+ OK ans -> iputStrLn (show ans)+ Error e -> iputStrLn (show e) process fn (DebugInfo n) = do i <- getIState@@ -949,7 +960,7 @@ when (not (null cg')) $ do iputStrLn "Call graph:\n" iputStrLn (show cg') when (not (null fn)) $ iputStrLn (show fn)-process fn (Search t) = searchByType t+process fn (Search pkgs t) = searchByType pkgs t process fn (CaseSplitAt updatefile l n) = caseSplitAt fn updatefile l n process fn (AddClauseFrom updatefile l n)@@ -1067,9 +1078,9 @@ runIO $ hClose tmph t <- codegen ir <- compile t tmpn m- runIO $ generate t (head (idris_imported ist)) ir+ runIO $ generate t (fst (head (idris_imported ist))) ir case idris_outputmode ist of- RawOutput h -> do runIO $ system tmpn+ RawOutput h -> do runIO $ rawSystem tmpn [] return () IdeSlave n h -> runIO . hPutStrLn h $ IdeSlave.convSExp "run-program" tmpn n)@@ -1083,7 +1094,7 @@ [pexp $ PRef fc (sNS (sUN "main") ["Main"])]) ir <- compile codegen f m i <- getIState- runIO $ generate codegen (head (idris_imported i)) ir+ runIO $ generate codegen (fst (head (idris_imported i))) ir where fc = fileFC "main" process fn (LogLvl i) = setLogLevel i -- Elaborate as if LHS of a pattern (debug command)@@ -1155,18 +1166,28 @@ handlers -> "Registered error handlers: " ++ (concat . intersperse ", " . map show) handlers process fn (SetConsoleWidth w) = setWidth w -process fn (Apropos a) =- do ist <- getIState+process fn (Apropos pkgs a) =+ do orig <- getIState+ when (not (null pkgs)) $ + iputStrLn $ "Searching packages: " ++ showSep ", " pkgs+ mapM_ loadPkgIndex pkgs+ ist <- getIState+ let mods = aproposModules ist (T.pack a) let names = apropos ist (T.pack a) let aproposInfo = [ (n, delabTy ist n, fmap (overview . fst) (lookupCtxtExact n (idris_docstrings ist))) | n <- sort names, isUN n ]- iRenderResult $ vsep (map (prettyDocumentedIst ist) aproposInfo)+ iRenderResult $ vsep (map (\(m, d) -> text "Module" <+> text m <$>+ ppD ist d <> line) mods) <$>+ vsep (map (prettyDocumentedIst ist) aproposInfo)+ putIState orig where isUN (UN _) = True isUN (NS n _) = isUN n isUN _ = False+ ppD ist = renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) + process fn (WhoCalls n) = do calls <- whoCalls n ist <- getIState@@ -1308,7 +1329,7 @@ -- | Invoke as if from command line. It is an error if there are unresolved totality problems. idris :: [Opt] -> IO (Maybe IState)-idris opts = do res <- runErrorT $ execStateT totalMain idrisInit+idris opts = do res <- runExceptT $ execStateT totalMain idrisInit case res of Left err -> do putStrLn $ pshow idrisInit err return Nothing@@ -1320,7 +1341,7 @@ [] -> return () -loadInputs :: [FilePath] -> Maybe Int -> Idris ()+loadInputs :: [FilePath] -> Maybe Int -> Idris [FilePath] loadInputs inputs toline -- furthest line to read in input source files = idrisCatch (do ist <- getIState@@ -1349,7 +1370,7 @@ when (not (all ibc ifiles) || loadCode) $ tryLoad False (filter (not . ibc) ifiles) -- return the files that need rechecking- return ifiles)+ return (input, ifiles)) ninputs inew <- getIState let tidata = idris_tyinfodata inew@@ -1358,7 +1379,7 @@ case errSpan inew of Nothing -> do putIState (ist { idris_tyinfodata = tidata })- ibcfiles <- mapM findNewIBC (nub (concat ifiles))+ ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles))) tryLoad True (mapMaybe id ibcfiles) _ -> return () ist <- getIState@@ -1369,7 +1390,7 @@ [] -> performUsageAnalysis -- interactive _ -> return [] -- batch, will be checked by the compiler - return ())+ return (map fst ifiles)) (\e -> do i <- getIState case e of At f e' -> do setErrSpan f@@ -1378,7 +1399,8 @@ _ -> do setErrSpan emptyFC -- FIXME! Propagate it -- Issue #1576 on the issue tracker. -- https://github.com/idris-lang/Idris-dev/issues/1576- iWarn emptyFC $ pprintErr i e)+ iWarn emptyFC $ pprintErr i e+ return []) where -- load all files, stop if any fail tryLoad :: Bool -> [IFileType] -> Idris () tryLoad keepstate [] = warnTotality >> return ()@@ -1395,7 +1417,7 @@ then Just l else Nothing _ -> Nothing- loadFromIFile f maxline+ loadFromIFile True f maxline inew <- getIState -- FIXME: Save these in IBC to avoid this hack! Need to -- preserve it all from source inputs@@ -1524,7 +1546,10 @@ iputStrLn banner orig <- getIState- when (not idesl) $ loadInputs inputs Nothing+ mods <- if idesl then return [] else loadInputs inputs Nothing+ let efile = case inputs of+ [] -> ""+ (f:_) -> f runIO $ hSetBuffering stdout LineBuffering @@ -1560,10 +1585,14 @@ historyFile <- fmap (</> "repl" </> "history") getIdrisUserDataDir + when ok $ case opt getPkgIndex opts of+ (f : _) -> writePkgIndex f+ _ -> return ()+ when (runrepl && not idesl) $ do -- clearOrigPats- startServer port orig inputs- runInputT (replSettings (Just historyFile)) $ repl orig inputs+ startServer port orig mods+ runInputT (replSettings (Just historyFile)) $ repl orig mods efile let idesock = IdeslaveSocket `elem` opts when (idesl) $ ideslaveStart idesock orig inputs ok <- noErrors@@ -1582,7 +1611,7 @@ addIBC (IBCImportDir (ddir </> p)) runMain :: Idris () -> IO ()-runMain prog = do res <- runErrorT $ execStateT prog idrisInit+runMain prog = do res <- runExceptT $ execStateT prog idrisInit case res of Left err -> putStrLn $ "Uncaught error: " ++ show err Right _ -> return ()@@ -1697,6 +1726,10 @@ getExecScript :: Opt -> Maybe String getExecScript (InterpretScript expr) = Just expr getExecScript _ = Nothing++getPkgIndex :: Opt -> Maybe FilePath+getPkgIndex (PkgIndex file) = Just file+getPkgIndex _ = Nothing getEvalExpr :: Opt -> Maybe String getEvalExpr (EvalExpr expr) = Just expr
src/Idris/REPLParser.hs view
@@ -1,5 +1,5 @@ -module Idris.REPLParser(parseCmd) where+module Idris.REPLParser (parseCmd, help, allHelp) where import System.FilePath ((</>)) import System.Console.ANSI (Color(..))@@ -7,125 +7,184 @@ import Idris.Colours import Idris.AbsSyntax import Idris.Core.TT+import Idris.Help import qualified Idris.Parser as P import Control.Applicative import Control.Monad.State.Strict import Text.Parser.Combinators-import Text.Parser.Char(anyChar)+import Text.Parser.Char(anyChar,oneOf) import Text.Trifecta(Result, parseString) import Text.Trifecta.Delta import Debug.Trace import Data.List import Data.List.Split(splitOn)-import Data.Char(toLower)+import Data.Char(isSpace, toLower) import qualified Data.ByteString.UTF8 as UTF8 parseCmd :: IState -> String -> String -> Result (Either String Command)-parseCmd i inputname = P.runparser pCmd i inputname--pCmd :: P.IdrisParser (Either String Command)-pCmd = do c <- cmd ["q", "quit"]; noArgs c Quit- <|> do c <- cmd ["h", "?", "help"]; noArgs c Help- <|> do c <- cmd ["w", "warranty"]; noArgs c Warranty- <|> do c <- cmd ["r", "reload"]; noArgs c Reload- <|> do c <- cmd ["exec", "execute"]; noArgs c Execute- <|> do c <- cmd ["proofs"]; noArgs c Proofs- <|> do c <- cmd ["u", "universes"]; noArgs c Universes- <|> do c <- cmd ["errorhandlers"]; noArgs c ListErrorHandlers- <|> do c <- cmd ["m", "metavars"]; noArgs c Metavars- <|> do c <- cmd ["e", "edit"]; noArgs c Edit+parseCmd i inputname = P.runparser pCmd i inputname . dropWhile isSpace - <|> do c <- cmd ["d", "def"]; fnNameArg c Defn- <|> do c <- cmd ["total"]; fnNameArg c TotCheck- <|> do c <- cmd ["printdef"]; fnNameArg c PrintDef- <|> do c <- cmd ["transinfo"]; fnNameArg c TransformInfo- <|> do c <- cmd ["wc", "whocalls"]; fnNameArg c WhoCalls- <|> do c <- cmd ["cw", "callswho"]; fnNameArg c CallsWho- <|> do c <- cmd ["di", "dbginfo"]; fnNameArg c DebugInfo- <|> do c <- cmd ["miss", "missing"]; fnNameArg c Missing+type CommandTable = [ ( [String], CmdArg, String+ , String -> P.IdrisParser (Either String Command) ) ] - <|> do c <- cmd ["t", "type"]; exprArg c Check- <|> do c <- cmd ["x"]; exprArg c ExecVal- <|> do c <- cmd ["patt"]; exprArg c Pattelab- <|> do c <- cmd ["spec"]; exprArg c Spec- <|> do c <- cmd ["hnf"]; exprArg c HNF- <|> do c <- cmd ["inline"]; exprArg c TestInline+help :: [([String], CmdArg, String)]+help = (["<expr>"], NoArg, "Evaluate an expression") : + [ (map (':' :) names, args, text) | (names, args, text, _) <- parserCommandsForHelp ] - <|> do c <- cmd ["rmproof"]; nameArg c RmProof- <|> do c <- cmd ["showproof"]; nameArg c ShowProof- <|> do c <- cmd ["p", "prove"]; nameArg c Prove+allHelp :: [([String], CmdArg, String)]+allHelp = [ (map (':' :) names, args, text) + | (names, args, text, _) <- parserCommandsForHelp ++ parserCommands ] - <|> do c <- cmd ["set"]; optArg c SetOpt- <|> do c <- cmd ["unset"]; optArg c UnsetOpt+parserCommandsForHelp :: CommandTable+parserCommandsForHelp = + [ exprArgCmd ["t", "type"] Check "Check the type of an expression"+ , nameArgCmd ["miss", "missing"] Missing "Show missing clauses"+ , (["doc"], NameArg, "Show internal documentation", cmd_doc)+ , (["mkdoc"], NamespaceArg, "Generate IdrisDoc for namespace(s) and dependencies"+ , genArg "namespace" (many anyChar) MakeDoc)+ , (["apropos"], SeqArgs (OptionalArg PkgArgs) NameArg, " Search names, types, and documentation"+ , cmd_apropos)+ , (["s", "search"], SeqArgs (OptionalArg PkgArgs) ExprArg+ , " Search for values by type", cmd_search)+ , nameArgCmd ["wc", "whocalls"] WhoCalls "List the callers of some name"+ , nameArgCmd ["cw", "callswho"] CallsWho "List the callees of some name"+ , nameArgCmd ["total"] TotCheck "Check the totality of a name"+ , noArgCmd ["r", "reload"] Reload "Reload current file"+ , (["l", "load"], FileArg, "Load a new file"+ , strArg (\f -> Load f Nothing))+ , (["cd"], FileArg, "Change working directory"+ , strArg ChangeDirectory)+ , (["module"], ModuleArg, "Import an extra module", moduleArg ModImport) -- NOTE: dragons+ , noArgCmd ["e", "edit"] Edit "Edit current file using $EDITOR or $VISUAL"+ , noArgCmd ["m", "metavars"] Metavars "Show remaining proof obligations (metavariables)"+ , (["p", "prove"], MetaVarArg, "Prove a metavariable"+ , nameArg Prove)+ , (["a", "addproof"], NameArg, "Add proof to source file", cmd_addproof)+ , (["rmproof"], NameArg, "Remove proof from proof stack"+ , nameArg RmProof)+ , (["showproof"], NameArg, "Show proof"+ , nameArg ShowProof)+ , noArgCmd ["proofs"] Proofs "Show available proofs"+ , exprArgCmd ["x"] ExecVal "Execute IO actions resulting from an expression using the interpreter"+ , (["c", "compile"], FileArg, "Compile to an executable [codegen] <filename>", cmd_compile)+ , noArgCmd ["exec", "execute"] Execute "Compile to an executable and run"+ , (["dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)", cmd_dynamic)+ , (["dynamic"], NoArg, "List dynamically loaded C libraries", cmd_dynamic)+ , noArgCmd ["?", "h", "help"] Help "Display this help text"+ , optArgCmd ["set"] SetOpt "Set an option (errorcontext, showimplicits)"+ , optArgCmd ["unset"] UnsetOpt "Unset an option"+ , (["color", "colour"], ColourArg+ , "Turn REPL colours on or off; set a specific colour"+ , cmd_colour)+ , (["consolewidth"], ConsoleWidthArg, "Set the width of the console", cmd_consolewidth)+ , noArgCmd ["q", "quit"] Quit "Exit the Idris system"+ , noArgCmd ["w", "warranty"] Warranty "Displays warranty information"+ , (["let"], ManyArgs DeclArg+ , "Evaluate a declaration, such as a function definition, instance implementation, or fixity declaration"+ , cmd_let)+ , (["unlet", "undefine"], ManyArgs NameArg+ , "Remove the listed repl definitions, or all repl definitions if no names given"+ , cmd_unlet)+ , nameArgCmd ["printdef"] PrintDef "Show the definition of a function"+ , (["pp", "pprint"], (SeqArgs OptionArg (SeqArgs NumberArg NameArg))+ , "Pretty prints an Idris function in either LaTeX or HTML and for a specified width."+ , cmd_pprint)+ ] - <|> do c <- cmd ["l", "load"]; strArg c (\f -> Load f Nothing)- <|> do c <- cmd ["cd"]; strArg c ChangeDirectory- <|> do c <- cmd ["apropos"]; strArg c Apropos- <|> do c <- cmd ["mkdoc"]; strArg c MakeDoc+parserCommands = + [ noArgCmd ["u", "universes"] Universes "Display universe constraints"+ , noArgCmd ["errorhandlers"] ListErrorHandlers "List registered error handlers" - <|> do c <- cmd ["cs", "casesplit"]; proofArg c CaseSplitAt- <|> do c <- cmd ["apc", "addproofclause"]; proofArg c AddProofClauseFrom- <|> do c <- cmd ["ac", "addclause"]; proofArg c AddClauseFrom- <|> do c <- cmd ["am", "addmissing"]; proofArg c AddMissing- <|> do c <- cmd ["mw", "makewith"]; proofArg c MakeWith- <|> do c <- cmd ["ml", "makelemma"]; proofArg c MakeLemma+ , nameArgCmd ["d", "def"] Defn "Display a name's internal definitions"+ , nameArgCmd ["transinfo"] TransformInfo "Show relevant transformation rules for a name"+ , nameArgCmd ["di", "dbginfo"] DebugInfo "Show debugging information for a name" - <|> do c <- cmd ["pp", "pprint"]; cmd_pprint c- <|> do c <- cmd ["doc"]; cmd_doc c- <|> do c <- cmd ["dynamic"]; cmd_dynamic c- <|> do c <- cmd ["consolewidth"]; cmd_consolewidth c- <|> do c <- cmd ["module"]; cmd_module c- <|> do c <- cmd ["c", "compile"]; cmd_compile c- <|> do c <- cmd ["a", "addproof"]; cmd_addproof c- <|> do c <- cmd ["log"]; cmd_log c- <|> do c <- cmd ["let"]; cmd_let c- <|> do c <- cmd ["unlet","undefine"]; cmd_unlet c- <|> do c <- cmd ["lto", "loadto"]; cmd_loadto c- <|> do c <- cmd ["color", "colour"]; cmd_colour c- <|> do c <- cmd ["s", "search"]; cmd_search c- <|> do c <- cmd ["ps", "proofsearch"]; cmd_proofsearch c- <|> do c <- cmd ["ref", "refine"]; cmd_refine c+ , exprArgCmd ["patt"] Pattelab "(Debugging) Elaborate pattern expression"+ , exprArgCmd ["spec"] Spec "?"+ , exprArgCmd ["hnf"] HNF "?"+ , exprArgCmd ["inline"] TestInline "?"+ , proofArgCmd ["cs", "casesplit"] CaseSplitAt + ":cs <line> <name> splits the pattern variable on the line"+ , proofArgCmd ["apc", "addproofclause"] AddProofClauseFrom+ ":apc <line> <name> adds a pattern-matching proof clause to name on line"+ , proofArgCmd ["ac", "addclause"] AddClauseFrom+ ":ac <line> <name> adds a clause for the definition of the name on the line"+ , proofArgCmd ["am", "addmissing"] AddMissing+ ":am <line> <name> adds all missing pattern matches for the name on the line"+ , proofArgCmd ["mw", "makewith"] MakeWith+ ":mw <line> <name> adds a with clause for the definition of the name on the line"+ , proofArgCmd ["ml", "makelemma"] MakeLemma "?"+ , (["log"], NumberArg, "Set logging verbosity level", cmd_log)+ , (["lto", "loadto"], SeqArgs NumberArg FileArg+ , "Load file up to line number", cmd_loadto)+ , (["ps", "proofsearch"], NoArg+ , ":ps <line> <name> <names> does proof search for name on line, with names as hints"+ , cmd_proofsearch)+ , (["ref", "refine"], NoArg+ , ":ref <line> <name> <name'> attempts to partially solve name on line, with name' as hint, introducing metavariables for arguments that aren't inferrable"+ , cmd_refine)+ , (["debugunify"], SeqArgs ExprArg ExprArg+ , "(Debugging) Try to unify two expressions", const $ do+ l <- P.simpleExpr defaultSyntax + r <- P.simpleExpr defaultSyntax + eof+ return (Right (DebugUnify l r))+ )+ ] - <|> unrecognized- <|> nop- <|> eval+noArgCmd names command doc = + (names, NoArg, doc, noArgs command)+nameArgCmd names command doc = + (names, NameArg, doc, fnNameArg command)+exprArgCmd names command doc = + (names, ExprArg, doc, exprArg command)+metavarArgCmd names command doc = + (names, MetaVarArg, doc, fnNameArg command)+optArgCmd names command doc = + (names, OptionArg, doc, optArg command)+proofArgCmd names command doc = + (names, NoArg, doc, proofArg command) - where nop = do P.whiteSpace; eof; return (Right NOP)- eval = exprArg "" Eval- unrecognized = do - P.lchar ':' +pCmd :: P.IdrisParser (Either String Command)+pCmd = choice [ do c <- cmd names; parser c + | (names, _, _, parser) <- parserCommandsForHelp ++ parserCommands ]+ <|> unrecognized + <|> nop + <|> eval+ where nop = do eof; return (Right NOP)+ eval = exprArg Eval ""+ unrecognized = do+ P.lchar ':' cmd <- many anyChar let cmd' = takeWhile (/=' ') cmd return (Left $ "Unrecognized command: " ++ cmd') cmd :: [String] -> P.IdrisParser String-cmd xs = try $ do +cmd xs = try $ do P.lchar ':' docmd sorted_xs- + where docmd [] = fail "Could not parse command" docmd (x:xs) = try (P.reserved x >> return x) <|> docmd xs- + sorted_xs = sortBy (\x y -> compare (length y) (length x)) xs -noArgs :: String -> Command -> P.IdrisParser (Either String Command)-noArgs name cmd = do+noArgs :: Command -> String -> P.IdrisParser (Either String Command)+noArgs cmd name = do let emptyArgs = do- P.whiteSpace eof return (Right cmd) let failure = return (Left $ ":" ++ name ++ " takes no arguments") - try emptyArgs <|> failure+ emptyArgs <|> failure -exprArg :: String -> (PTerm -> Command) -> P.IdrisParser (Either String Command)-exprArg name cmd = do- P.whiteSpace+exprArg :: (PTerm -> Command) -> String -> P.IdrisParser (Either String Command)+exprArg cmd name = do let noArg = do eof return $ Left ("Usage is :" ++ name ++ " <expression>")@@ -136,51 +195,45 @@ try noArg <|> properArg -fnNameArg :: String -> (Name -> Command) -> P.IdrisParser (Either String Command)-fnNameArg name cmd = do- P.whiteSpace- let emptyArgs = do eof- return $ Left ("Usage is :" ++ name ++ " <functionname>")- oneArg = do n <- P.fnName- eof- return (Right (cmd n))- badArg = return $ Left ("Usage is :" ++ name ++ " <functionname>")- try emptyArgs <|> try oneArg <|> badArg -nameArg :: String -> (Name -> Command) -> P.IdrisParser (Either String Command)-nameArg name cmd = do- P.whiteSpace- let emptyArgs = do eof- return $ Left ("Usage is :" ++ name ++ " <functionname>")- oneArg = do n <- P.name+genArg :: String -> P.IdrisParser a -> (a -> Command) + -> String -> P.IdrisParser (Either String Command)+genArg argName argParser cmd name = do+ let emptyArgs = do eof; failure+ oneArg = do arg <- argParser eof- return (Right (cmd n))- badArg = return $ Left ("Usage is :" ++ name ++ " <functionname>")- try emptyArgs <|> try oneArg <|> badArg+ return (Right (cmd arg))+ try emptyArgs <|> oneArg <|> failure+ where+ failure = return $ Left ("Usage is :" ++ name ++ " <" ++ argName ++ ">") -strArg :: String -> (String -> Command) -> P.IdrisParser (Either String Command)-strArg name cmd = do- n <- many anyChar- eof- return (Right (cmd n))+nameArg, fnNameArg :: (Name -> Command) -> String -> P.IdrisParser (Either String Command)+nameArg = genArg "name" P.name+fnNameArg = genArg "functionname" P.fnName -optArg :: String -> (Opt -> Command) -> P.IdrisParser (Either String Command)-optArg name cmd = do+strArg :: (String -> Command) -> String -> P.IdrisParser (Either String Command)+strArg = genArg "string" (many anyChar)++moduleArg :: (FilePath -> Command) -> String -> P.IdrisParser (Either String Command)+moduleArg = genArg "module" (fmap toPath P.identifier) + where+ toPath n = foldl1' (</>) $ splitOn "." n++optArg :: (Opt -> Command) -> String -> P.IdrisParser (Either String Command)+optArg cmd name = do let emptyArgs = do eof return $ Left ("Usage is :" ++ name ++ " <option>") let oneArg = do- P.whiteSpace o <- pOption P.whiteSpace eof return (Right (cmd o)) - let failure = do- return $ Left "Unrecognized setting"+ let failure = return $ Left "Unrecognized setting" - try emptyArgs <|> try oneArg <|> failure+ try emptyArgs <|> oneArg <|> failure where pOption :: P.IdrisParser Opt@@ -191,9 +244,8 @@ <|> do discard (P.symbol "nobanner") ; return NoBanner <|> do discard (P.symbol "warnreach"); return WarnReach -proofArg :: String -> (Bool -> Int -> Name -> Command) -> P.IdrisParser (Either String Command)-proofArg name cmd = do- P.whiteSpace+proofArg :: (Bool -> Int -> Name -> Command) -> String -> P.IdrisParser (Either String Command)+proofArg cmd name = do upd <- option False $ do P.lchar '!' return True@@ -208,7 +260,7 @@ eof return $ Right (DocStr (Right c)) - let fnName = fnNameArg name (\n -> DocStr (Left n))+ let fnName = fnNameArg (\n -> DocStr (Left n)) name try constant <|> fnName @@ -225,7 +277,7 @@ cmd_dynamic :: String -> P.IdrisParser (Either String Command) cmd_dynamic name = do- let emptyArgs = noArgs name ListDynamic+ let emptyArgs = noArgs ListDynamic name let oneArg = do l <- many anyChar return $ Right (DynamicLink l)@@ -236,7 +288,6 @@ cmd_pprint :: String -> P.IdrisParser (Either String Command) cmd_pprint name = do- P.whiteSpace fmt <- ppFormat P.whiteSpace n <- fmap fromInteger P.natural@@ -250,13 +301,6 @@ <|> (discard (P.symbol "latex") >> return LaTeXOutput) -cmd_module :: String -> P.IdrisParser (Either String Command)-cmd_module name = do- f <- P.identifier- eof;- return (Right (ModImport (toPath f)))- where- toPath n = foldl1' (</>) $ splitOn "." n cmd_compile :: String -> P.IdrisParser (Either String Command) cmd_compile name = do@@ -305,8 +349,7 @@ return (Right (NewDefn defn)) cmd_unlet :: String -> P.IdrisParser (Either String Command)-cmd_unlet name = do- (Right . Undefine) `fmap` many P.name+cmd_unlet name = (Right . Undefine) `fmap` many P.name cmd_loadto :: String -> P.IdrisParser (Either String Command) cmd_loadto name = do@@ -315,8 +358,7 @@ return (Right (Load f (Just (fromInteger toline)))) cmd_colour :: String -> P.IdrisParser (Either String Command)-cmd_colour name = do- pSetColourCmd >>= return . Right+cmd_colour name = fmap Right pSetColourCmd where colours :: [(String, Maybe Color)]@@ -376,16 +418,28 @@ (concat . intersperse ", " . map fst) colourTypes doColourType ((s,ct):cts) = (try (P.symbol s) >> return ct) <|> doColourType cts +idChar = oneOf (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_']) +cmd_apropos :: String -> P.IdrisParser (Either String Command)+cmd_apropos = packageBasedCmd (some idChar) Apropos++packageBasedCmd :: P.IdrisParser a -> ([String] -> a -> Command)+ -> String -> P.IdrisParser (Either String Command)+packageBasedCmd valParser cmd name = do+ pkgs <- option [] . try $ do+ P.lchar '('+ pks <- sepBy (some idChar) (P.lchar ',')+ P.lchar ')'+ return pks+ val <- valParser+ return (Right (cmd pkgs val))+ cmd_search :: String -> P.IdrisParser (Either String Command)-cmd_search name = do- P.whiteSpace;- t <- P.typeExpr (defaultSyntax { implicitAllowed = True })- return (Right (Search t))+cmd_search = packageBasedCmd + (P.typeExpr (defaultSyntax { implicitAllowed = True })) Search cmd_proofsearch :: String -> P.IdrisParser (Either String Command) cmd_proofsearch name = do- P.whiteSpace upd <- option False (do P.lchar '!'; return True) l <- P.natural; n <- P.name; hints <- many P.fnName@@ -393,7 +447,6 @@ cmd_refine :: String -> P.IdrisParser (Either String Command) cmd_refine name = do- P.whiteSpace upd <- option False (do P.lchar '!'; return True) l <- P.natural; n <- P.name; hint <- P.fnName
src/Idris/Transforms.hs view
@@ -71,6 +71,11 @@ -- ++ "\n" ++ show tm ++ " GIVES\n" ++ show (depat ms rhs)) $ = Just $ depat ms rhs | otherwise = Nothing+-- ASSUMPTION: The names in the transformation rule bindings cannot occur+-- in the term being transformed.+-- (In general, this would not be true, but when we elaborate transformation+-- rules we mangle the names so that it is true. While this feels a bit+-- hacky, it's much easier to think about than mangling de Bruijn indices). where depat ms (Bind n (PVar t) sc) = case lookup n ms of Just tm -> depat ms (subst n tm sc)
src/Idris/TypeSearch.hs view
@@ -6,7 +6,7 @@ import Control.Applicative (Applicative (..), (<$>), (<*>), (<|>)) import Control.Arrow (first, second, (&&&), (***))-import Control.Monad (guard)+import Control.Monad (when, guard) import Data.List (find, partition, (\\)) import Data.Map (Map)@@ -20,7 +20,7 @@ import qualified Data.Text as T (pack, isPrefixOf) import Data.Traversable (traverse) -import Idris.AbsSyntax (addUsingConstraints, addImpl, getIState, putIState, implicit)+import Idris.AbsSyntax (addUsingConstraints, addImpl, getIState, putIState, implicit, logLvl) import Idris.AbsSyntaxTree (class_instances, ClassInfo, defaultSyntax, eqTy, Idris, IState (idris_classes, idris_docstrings, tt_ctxt, idris_outputmode), implicitAllowed, OutputMode(..), PTerm, toplevel)@@ -30,20 +30,24 @@ import Idris.Delaborate (delabTy) import Idris.Docstrings (noDocs, overview) import Idris.Elab.Type (elabType)-import Idris.Output (iRenderOutput, iPrintResult, iRenderResult, prettyDocumentedIst)+import Idris.Output (iputStrLn, iRenderOutput, iPrintResult, iRenderResult, prettyDocumentedIst)+import Idris.IBC import Prelude hiding (pred) import Util.Pretty (text, char, vsep, (<>), Doc, annotate) -searchByType :: PTerm -> Idris ()-searchByType pterm = do+searchByType :: [String] -> PTerm -> Idris ()+searchByType pkgs pterm = do+ i <- getIState -- save original+ when (not (null pkgs)) $ + iputStrLn $ "Searching packages: " ++ showSep ", " pkgs+ + mapM_ loadPkgIndex pkgs pterm' <- addUsingConstraints syn emptyFC pterm pterm'' <- implicit toplevel syn name pterm'- i <- getIState let pterm''' = addImpl i pterm'' ty <- elabType toplevel syn (fst noDocs) (snd noDocs) emptyFC [] name pterm'- putIState i -- don't actually make any changes let names = searchUsing searchPred i ty let names' = take numLimit names let docs =@@ -54,6 +58,7 @@ RawOutput _ -> do mapM_ iRenderOutput docs iPrintResult "" IdeSlave _ _ -> iRenderResult (vsep docs)+ putIState i -- don't actually make any changes where numLimit = 50 syn = defaultSyntax { implicitAllowed = True } -- syntax@@ -78,7 +83,7 @@ || n `elem` map T.pack ["believe_me", "really_believe_me"] special _ = False --- Our default search predicate.+-- | Our default search predicate. searchPred :: IState -> Type -> [(Name, Type)] -> [(Name, Score)] searchPred istate ty1 = matcher where maxScore = 100@@ -115,7 +120,7 @@ (arguments, theRemovedArgs, retTy) = go [] [] t -- NOTE : args are in reverse order- go args removedArgs (Bind n (Pi ty _) sc) = let arg = (n, ty) in+ go args removedArgs (Bind n (Pi _ ty _) sc) = let arg = (n, ty) in if removePred ty then go args (arg : removedArgs) sc else go (arg : args) removedArgs sc@@ -167,10 +172,12 @@ both :: (a -> b) -> Sided a -> Sided b both f (Sided l r) = Sided (f l) (f r) +-- | Keeps a record of the modifications made to match one type+-- signature with another data Score = Score- { transposition :: !Int- , equalityFlips :: !Int- , asymMods :: !(Sided AsymMods)+ { transposition :: !Int -- ^ transposition of arguments+ , equalityFlips :: !Int -- ^ application of symmetry of equality+ , asymMods :: !(Sided AsymMods) -- ^ "directional" modifications } deriving (Eq, Show) displayScore :: Score -> Doc OutputAnnotation@@ -183,6 +190,9 @@ annotated ordr = annotate (AnnSearchResult ordr) . text noMods (Mods app tcApp tcIntro) = app + tcApp + tcIntro == 0 +-- | This allows the search to stop expanding on a certain state if its+-- score is already too high. Returns 'True' if the algorithm should keep+-- exploring from this state, and 'False' otherwise. scoreCriterion :: Score -> Bool scoreCriterion (Score _ _ amods) = not ( sided (&&) (both ((> 0) . argApp) amods)@@ -190,6 +200,8 @@ || sided (||) (both (\(Mods _ tcApp tcIntro) -> tcApp > 3 || tcIntro > 3) amods) ) +-- | Convert a 'Score' to an 'Int' to provide an order for search results.+-- Lower scores are better. defaultScoreFunction :: Score -> Int defaultScoreFunction (Score trans eqFlip amods) = trans + eqFlip + linearPenalty + upAndDowncastPenalty@@ -201,6 +213,10 @@ upAndDowncastPenalty = 100 * sided (*) (both (\(Mods app tcApp tcIntro) -> 2 * app + tcApp + tcIntro) amods) +instance Ord Score where+ compare = comparing defaultScoreFunction++ instance Monoid a => Monoid (Sided a) where mempty = Sided mempty mempty (Sided l1 r1) `mappend` (Sided l2 r2) = Sided (l1 `mappend` l2) (r1 `mappend` r2)@@ -244,7 +260,7 @@ deleteName :: Name -> (ArgsDAG, Classes) -> (ArgsDAG, Classes) deleteName n (args, classes) = (deleteFromDag n args, filter ((/= n) . fst) classes) -tcToMaybe :: TC' e a -> Maybe a+tcToMaybe :: TC a -> Maybe a tcToMaybe (OK x) = Just x tcToMaybe (Error _) = Nothing @@ -271,9 +287,6 @@ getClassName _ = [] -instance Ord Score where- compare = comparing defaultScoreFunction- -- | Compute the power set subsets :: [a] -> [[a]] subsets [] = [[]]@@ -403,7 +416,7 @@ 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 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 ty2 [] (map fst $ holes state) [] (state', queueAdditions) <- resolveUnis res state guard $ scoreCriterion (score state') unifyQueue state' (queue ++ queueAdditions)@@ -422,17 +435,17 @@ getClassName (P (TCon _ _) className _) = [className] getClassName _ = [] - -- Just if the computation hasn't totally failed yet, Nothing if it has- -- Left if we haven't found a terminal state, Right if we have+ -- 'Just' if the computation hasn't totally failed yet, 'Nothing' if it has+ -- 'Left' if we haven't found a terminal state, 'Right' if we have nextStepsQueue :: Q.PQueue Score State -> Maybe (Either (Q.PQueue Score State) Score) nextStepsQueue queue = do ((nextScore, next), rest) <- Q.minViewWithKey queue- if isFinal next - then Just $ Right nextScore+ Just $ if isFinal next + then Right nextScore else let additions = if scoreCriterion nextScore then Q.fromList [ (score state, state) | state <- nextSteps next ] else Q.empty in- Just $ Left (Q.union rest additions)+ Left (Q.union rest additions) where isFinal (State [] (Sided ([], []) ([], [])) _ _) = True isFinal _ = False
src/Pkg/PParser.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE CPP #-}+#if !(MIN_VERSION_base(4,8,0)) {-# LANGUAGE OverlappingInstances #-}+#endif module Pkg.PParser where @@ -31,7 +34,11 @@ } deriving Show +#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPING #-} TokenParsing PParser where+#else instance TokenParsing PParser where+#endif someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()
src/Pkg/Package.hs view
@@ -12,7 +12,7 @@ import Control.Monad import Control.Monad.Trans.State.Strict (execStateT)-import Control.Monad.Error (runErrorT)+import Control.Monad.Except (runExceptT) import Data.List import Data.List.Split(splitOn)@@ -23,12 +23,14 @@ import Idris.Output (pshow) import Idris.AbsSyntax import Idris.IdrisDoc+import Idris.IBC import Idris.Output--import IRTS.System+import Idris.Imports import Pkg.PParser +import IRTS.System+ -- To build a package: -- * read the package description -- * check all the library dependencies exist@@ -40,17 +42,18 @@ buildPkg :: Bool -> (Bool, FilePath) -> IO () buildPkg warnonly (install, fp) = do pkgdesc <- parseDesc fp+ let idx = PkgIndex (pkgIndex (pkgname pkgdesc)) ok <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc) when (and ok) $ do dir <- getCurrentDirectory setCurrentDirectory $ dir </> sourcedir pkgdesc make (makefile pkgdesc) m_ist <- case (execout pkgdesc) of- Nothing -> buildMods (NoREPL : Verbose : idris_opts pkgdesc)+ Nothing -> buildMods (idx : NoREPL : Verbose : idris_opts pkgdesc) (modules pkgdesc) Just o -> do let exec = dir </> o buildMods- (NoREPL : Verbose : Output exec : idris_opts pkgdesc)+ (idx : NoREPL : Verbose : Output exec : idris_opts pkgdesc) [idris_main pkgdesc] setCurrentDirectory dir case m_ist of@@ -60,14 +63,7 @@ case errSpan ist of Just _ -> exitWith (ExitFailure 1) _ -> return ()- -- Also give up if there are metavariables to solve- case (map fst (idris_metavars ist) \\ primDefs) of- _ -> when install $ installPkg pkgdesc--- ms -> do if install--- then putStrLn "Can't install: there are undefined metavariables:"--- else putStrLn "There are undefined metavariables:"--- putStrLn $ "\t" ++ show ms--- exitWith (ExitFailure 1)+ when install $ installPkg pkgdesc -- | Type check packages only --@@ -122,6 +118,7 @@ setCurrentDirectory $ dir </> sourcedir pkgdesc clean (makefile pkgdesc) mapM_ rmIBC (modules pkgdesc)+ rmIdx (pkgname pkgdesc) case execout pkgdesc of Nothing -> return () Just s -> rmFile $ dir </> s@@ -145,7 +142,7 @@ setCurrentDirectory $ pkgDir </> sourcedir pkgdesc make (makefile pkgdesc) setCurrentDirectory $ pkgDir- let run l = runErrorT . (execStateT l)+ let run l = runExceptT . execStateT l load [] = return () load (f:fs) = do loadModule f; load fs loader = do idrisMain opts; load fs@@ -184,7 +181,7 @@ (tmpn', tmph') <- tempfile hClose tmph' m_ist <- idris (Filename tmpn : NoREPL : Verbose : Output tmpn' : idris_opts pkgdesc)- system tmpn'+ rawSystem tmpn' [] setCurrentDirectory dir case m_ist of Nothing -> exitWith (ExitFailure 1)@@ -203,7 +200,8 @@ = do dir <- getCurrentDirectory setCurrentDirectory $ dir </> sourcedir pkgdesc case (execout pkgdesc) of- Nothing -> mapM_ (installIBC (pkgname pkgdesc)) (modules pkgdesc)+ Nothing -> do mapM_ (installIBC (pkgname pkgdesc)) (modules pkgdesc)+ installIdx (pkgname pkgdesc) Just o -> return () -- do nothing, keep executable locally, for noe mapM_ (installObj (pkgname pkgdesc)) (objs pkgdesc) @@ -213,7 +211,6 @@ buildMods :: [Opt] -> [Name] -> IO (Maybe IState) buildMods opts ns = do let f = map (toPath . showCG) ns--- putStrLn $ "MODULE: " ++ show f idris (map Filename f ++ opts) where toPath n = foldl1' (</>) $ splitOn "." n @@ -224,7 +221,7 @@ (tmpf, tmph) <- tempfile hClose tmph let libtest = d </> "rts" </> "libtest.c"- e <- system $ gcc ++ " " ++ libtest ++ " -l" ++ f ++ " -o " ++ tmpf+ e <- rawSystem gcc [libtest, "-l" ++ f, "-o", tmpf] case e of ExitSuccess -> return True _ -> do if warn@@ -236,6 +233,11 @@ rmIBC :: Name -> IO () rmIBC m = rmFile $ toIBCFile m +rmIdx :: String -> IO ()+rmIdx p = do let f = pkgIndex p+ ex <- doesFileExist f+ when ex $ rmFile f + toIBCFile (UN n) = str n ++ ".ibc" toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : map str ns)) @@ -250,6 +252,14 @@ where getDest (UN n) = "" getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : map str ns)) +installIdx :: String -> IO ()+installIdx p = do d <- getTargetDir+ let f = pkgIndex p+ let destdir = d </> p + putStrLn $ "Installing " ++ f ++ " to " ++ destdir+ createDirectoryIfMissing True destdir+ copyFile f (destdir </> takeFileName f)+ return () installObj :: String -> String -> IO () installObj p o = do d <- getTargetDir@@ -269,13 +279,13 @@ -- | Invoke a Makefile's default target. make :: Maybe String -> IO () make Nothing = return ()-make (Just s) = do system $ "make -f " ++ s+make (Just s) = do rawSystem "make" ["-f", s] return () -- | Invoke a Makefile's clean target. clean :: Maybe String -> IO () clean Nothing = return ()-clean (Just s) = do system $ "make -f " ++ s ++ " clean"+clean (Just s) = do rawSystem "make" ["-f", s, "clean"] return () -- --------------------------------------------------------------------- [ EOF ]
test/Makefile view
@@ -8,13 +8,13 @@ @perl ./runtest.pl $(patsubst %.test,%,$@) test_java:- @perl ./runtest.pl without --codegen Java+ @perl ./runtest.pl without primitives004 --codegen Java test_js:- @perl ./runtest.pl without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 buffer001 basic011 --codegen node+ @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 sugar004 io003 buffer001 --codegen llvm+ @perl ./runtest.pl without primitives003 primitives004 sugar004 io003 buffer001 --codegen llvm update: /usr/bin/env perl ./runtest.pl all -u@@ -25,4 +25,3 @@ distclean: rm -f *~ rm -f */output-
test/basic001/basic001a.idr view
@@ -1,5 +1,7 @@ module Main +import Data.Vect+ data RLE : Vect n Char -> Type where REnd : RLE [] RChar : {xs : Vect k Char} ->
test/basic001/reg005.idr view
@@ -1,6 +1,10 @@ module Main -%flag C "-g3 -ggdb -O0"+import Data.Vect++%flag C "-g3"+%flag C "-ggdb"+%flag C "-O0" rep : (n : Nat) -> Char -> Vect n Char rep Z x = []
test/basic005/test019.lidr view
@@ -1,5 +1,7 @@ > module Main +> import Data.So+ > ifTrue : So True -> Nat > ifTrue Oh = S Z
test/basic006/expected view
@@ -1,14 +1,8 @@-test020a.idr:14:18:When elaborating right hand side of foo:+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 with List a- - Specifically:- Can't unify- Vect n a- with- List a [3, 2, 1] "Number 42"
test/basic006/test020.idr view
@@ -1,5 +1,7 @@ module Main +import Data.Vect+ implicit natInt : Nat -> Integer natInt x = cast x
test/basic006/test020a.idr view
@@ -1,5 +1,7 @@ module Main +import Data.Vect+ implicit forget : Vect n a -> List a forget [] = []
test/basic009/Multiple.idr view
@@ -1,4 +1,4 @@ module Multiple -import Prelude.Vect as X-import Prelude.List as X+import Data.Vect as X+import Data.List as X
+ test/basic012/basic012.idr view
@@ -0,0 +1,62 @@+import Data.Vect+import Control.Monad.State+import Control.Monad.Identity+ +VThing : Type+VThing = {n : Nat} -> Vect n Int -> Int++foo : Int -> Vect m Int -> ({n : Nat} -> Vect n Int -> Int) -> Int+foo x xs f = x + f xs++foo' : Int -> Vect m Int -> VThing -> Int+foo' x xs f = x + f xs++bar : Int -> VThing+bar y [] = 0+bar y (x :: xs) = y + x + bar y xs++vsum : Vect n Int -> Int+vsum [] = 0+vsum (x :: xs) = x + vsum xs++testfoo : Vect n Int -> Int+testfoo xs = foo 42 xs (\ xs => vsum xs)++testfoo2 : Vect n Int -> Int+testfoo2 xs = foo' 42 xs vsum++testfoo3 : Vect n Int -> Int+testfoo3 xs = foo 42 xs (bar 10)++AnyST : Type -> Type -> Type+AnyST s a = {m : _} -> Monad m => StateT s m a++foost: AnyST Int ()+foost = do x <- get+ put x++wibble : StateT Int Maybe ()+wibble = foost++appShow : Show a => ({b : _} -> Show b => b -> String) -> a -> String+appShow s x = s x++myshow : Show a => a -> String+myshow = show++baz : Int -> String+baz x = appShow myshow x ++ appShow show x++tupleId : ({a : _} -> a -> a) -> (a, b) -> (a, b)+tupleId f (a, b) = (f a, f b)++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])
+ test/basic012/expected view
@@ -0,0 +1,2 @@+4242+[1, 2, 3, 4, 5, 6]
+ test/basic012/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ basic012.idr -o basic012+./basic012+rm -f basic012 *.ibc
+ test/delab001/delab001.idr view
@@ -0,0 +1,16 @@+module Case++foo : Nat -> String+foo n = case n of+ Z => "z"+ S _ => "s"++bar : Nat -> String -> String+bar x y = case x of+ Z => y+ S _ => y ++ y++append : List a -> List a -> List a+append xs ys = case xs of+ Nil => ys+ (x :: xs) => x :: append xs ys
+ test/delab001/expected view
@@ -0,0 +1,13 @@+Type checking ./delab001.idr+foo : Nat -> String+foo n = case n of+ 0 => "z"+ S _ => "s"+bar : Nat -> String -> String+bar x y = case x of+ 0 => y+ S _ => (y ++ y)+append : List a -> List a -> List a+append xs ys = case xs of+ [] => ys+ (x :: xs) => (x :: (append xs ys))
+ test/delab001/input view
@@ -0,0 +1,4 @@+:consolewidth infinite+:printdef foo+:printdef bar+:printdef append
+ test/delab001/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --quiet --nocolor delab001.idr < input+rm -f *.ibc
test/dsl001/test001.idr view
@@ -1,5 +1,8 @@ module Main +import Data.Vect+import Data.Fin+ data Ty = TyInt | TyBool| TyFun Ty Ty interpTy : Ty -> Type
test/dsl002/Resimp.idr view
@@ -1,5 +1,8 @@ module Resimp +import Data.Vect+import public Data.Fin+ -- IO operations which read a resource data Reader : Type -> Type where MkReader : IO a -> Reader a
test/dsl003/DSLPi.idr view
@@ -1,5 +1,8 @@ module DSLPi +import Data.Fin+import Data.Vect+ data Ty = BOOL | INT | UNIT | ARR Ty Ty dsl simple_type
test/effects001/test021.idr view
@@ -1,5 +1,6 @@ module Main +import Effects import Effect.File import Effect.State import Effect.StdIO
test/effects001/test021a.idr view
@@ -1,5 +1,6 @@ module Main +import Effects import Effect.State import Effect.Exception import Effect.Random
test/effects002/test025.idr view
@@ -3,6 +3,7 @@ import Effects import Effect.Memory import Control.IOExcept+import Data.Vect MemoryIO : Type -> Type -> Type -> Type MemoryIO td ts r = { [ Dst ::: RAW_MEMORY td
+ test/effects003/VectMissing.idr view
@@ -0,0 +1,14 @@+module VectMissing++import Data.Fin+import Data.Vect++instance Uninhabited (Elem x []) where+ uninhabited Here impossible++shrink : (xs : Vect (S n) a) -> Elem x xs -> Vect n a+shrink (x :: ys) Here = ys+shrink (y :: []) (There p) = absurd p+shrink (y :: (x :: xs)) (There p) = y :: shrink (x :: xs) p++
+ test/effects003/expected view
@@ -0,0 +1,41 @@+------------++6 guesses left+Enter guess: No, sorry+------------++5 guesses left+Enter guess: Good guess!+----ee------++5 guesses left+Enter guess: Good guess!+----ee---i--++5 guesses left+Enter guess: Good guess!+-o--ee---i--++5 guesses left+Enter guess: Good guess!+-offee---i--++5 guesses left+Enter guess: Good guess!+coffee-c-i--++5 guesses left+Enter guess: Good guess!+coffeesc-i--++5 guesses left+Enter guess: Good guess!+coffeesc-ip-++5 guesses left+Enter guess: Good guess!+coffeescrip-++5 guesses left+Enter guess: Good guess!+You won! Successfully guessed coffeescript
+ test/effects003/hangman.idr view
@@ -0,0 +1,223 @@+module Main++import Effects+import Effect.StdIO+import Effect.Random+import Data.So+import Data.Fin+import Data.Vect+import VectMissing++-----------------------------------------------------------------------+-- GAME STATE+-----------------------------------------------------------------------++{- First, the game state, HState, where the type specifies how many guesses+are left and how many missing letters there are still to get. -}++data HState = Running Nat Nat | NotRunning++data Hangman : HState -> Type where+ Init : Hangman NotRunning -- initialising, but not ready+ GameWon : String -> Hangman NotRunning+ GameLost : String -> Hangman NotRunning+ MkH : (word : String) ->+ (guesses : Nat) ->+ (got : List Char) ->+ (missing : Vect m Char) ->+ Hangman (Running guesses m)++instance Default (Hangman NotRunning) where+ default = Init++instance Show (Hangman s) where+ show Init = "Not ready yet"+ show (GameWon w) = "You won! Successfully guessed " ++ w+ show (GameLost w) = "You lost! The word was " ++ w+ show (MkH w guesses got missing)+ = let w' = pack (map showGot (unpack w)) in+ w' ++ "\n\n" ++ show guesses ++ " guesses left"+ where showGot : Char -> Char+ showGot ' ' = '/'+ showGot c = if ((not (isAlpha c)) || (c `elem` got)) then c else '-'++{- Initialise the state with the missing letters in a word -}++total+letters : String -> List Char+letters x with (strM x)+ letters "" | StrNil = []+ letters (strCons y xs) | (StrCons y xs) + = let xs' = assert_total (letters xs) in+ if ((not (isAlpha y)) || (y `elem` xs')) then xs' else y :: xs'++initState : (x : String) -> Hangman (Running 6 (length (letters x)))+initState w = let xs = letters w in+ MkH w _ [] (fromList (letters w))++-----------------------------------------------------------------------+-- RULES+-----------------------------------------------------------------------++{- Now, the rules of the game, written as an Effect. +We can think of the rules as giving a protocol that the game player and+the machine must follow for an implementation of the game to make sense.+-}++data HangmanRules : Effect where++-- Rule:+-- Precondition: we can make a guess if we have one or more guess available +-- (S g) and one or more letters are still missing (S w)++-- Postcondition: return whether the character was in the word. If so, reduce+-- the number of missing letters, if not, reduce the number of guesses left++ Guess : (x : Char) ->+ { Hangman (Running (S g) (S w)) ==>+ {inword} (case inword of+ True => Hangman (Running (S g) w)+ False => Hangman (Running g (S w))) }+ HangmanRules Bool++-- The 'Won' operation requires that there are no missing letters++ Won : { Hangman (Running g 0) ==> Hangman NotRunning } HangmanRules ()++-- The 'Lost' operation requires that there are no guesses left++ Lost : { Hangman (Running 0 g) ==> Hangman NotRunning } HangmanRules ()++-- Set up a new game, initialised with 6 guesses and the missing letters in+-- the given word. Note that if there are no letters in the word, we won't+-- be able to run 'Guess'!++ NewWord : (w : String) -> + { h ==> Hangman (Running 6 (length (letters w))) } HangmanRules ()++-- Finally, allow us to get the current game state+ + Get : { h } HangmanRules h++HANGMAN : HState -> EFFECT+HANGMAN h = MkEff (Hangman h) HangmanRules++-- Promote explicit effecst to Eff programs++guess : Char ->+ { [HANGMAN (Running (S g) (S w))] ==>+ {inword} [HANGMAN (case inword of+ True => Running (S g) w+ False => Running g (S w))] } Eff Bool+guess c = call (Main.Guess c)++won : { [HANGMAN (Running g 0)] ==> [HANGMAN NotRunning]} Eff ()+won = call Won++lost : { [HANGMAN (Running 0 g)] ==> [HANGMAN NotRunning]} Eff ()+lost = call Lost++new_word : (w : String) ->+ { [HANGMAN h] ==> + [HANGMAN (Running 6 (length (letters w)))]} Eff ()+new_word w = call (NewWord w)++get : { [HANGMAN h] } Eff (Hangman h)+get = call Get++-----------------------------------------------------------------------+-- IMPLEMENTATION OF THE RULES+-----------------------------------------------------------------------++{- This effect handler simply updates the game state as necessary for+each operation. 'Guess' is slightly tricky, in that it needs to check+whether the letter is in the word, and branch accordingly (and if it+is in the word, update the vector of missing letters to be the right+length). -}++instance Handler HangmanRules m where+ handle (MkH w g got []) Won k = k () (GameWon w)+ handle (MkH w Z got m) Lost k = k () (GameLost w)++ handle st Get k = k st st+ handle st (NewWord w) k = k () (initState w)++ handle (MkH w (S g) got m) (Guess x) k =+ case isElem x m of+ No _ => k False (MkH w _ got m)+ Yes p => k True (MkH w _ (x :: got) (shrink m p))++-----------------------------------------------------------------------+-- USER INTERFACE +-----------------------------------------------------------------------++{- Finally, an implementation of the game which reads user input and calls+the operations we defined above when appropriate. ++The type indicates that the game must start in a running state, with some+guesses available, and get to a not running state (i.e. won or lost). +Since we picked a word at random, we can't actually make the assumption there+were valid letters in it!+-}++soRefl : So x -> (x = True)+soRefl Oh = Refl ++game : { [HANGMAN (Running (S g) w), STDIO] ==> + [HANGMAN NotRunning, STDIO] } Eff ()+game {w=Z} = won +game {w=S _}+ = do putStrLn (show !get)+ putStr "Enter guess: "+ let guess = trim !getStr+ case choose (not (guess == "")) of+ (Left p) => processGuess (strHead' guess (soRefl p))+ (Right p) => do putStrLn "Invalid input!"+ game+ where + processGuess : -- {g,w:_} ->+ Char -> { [HANGMAN (Running (S g) (S w)), STDIO] ==> + [HANGMAN NotRunning, STDIO] }+ Eff ()+ processGuess {g} c {w}+ = case !(guess c) of+ True => do putStrLn "Good guess!"+ case w of+ Z => won+ (S k) => game+ False => do putStrLn "No, sorry"+ case g of+ Z => lost+ (S k) => game++{- Some candidate words. We'll use programming languages. We don't want to+write the length explicitly, so infer it with a proof search. -}++words : ?wlen +words = with Vect ["idris","agda","haskell","miranda",+ "java","javascript","fortran","basic","racket",+ "coffeescript","rust","purescript","clean","links",+ "koka","cobol"]++wlen = proof search++{- It typechecks! Ship it! -}++runGame : { [HANGMAN NotRunning, RND, STDIO] } Eff ()+runGame = do srand 1234567890 + let w = index !(rndFin _) words+ new_word w+ game+ putStrLn (show !get)++{- I made a couple of mistakes while writing this. For example, the following +were caught by the type checker:++* Forgetting to check the 'Won' state before continuing with 'game'+* Accidentally checking the number of missing letters rather than the number+ of guesses when checking if 'Lost' was callable++-}++main : IO ()+main = run runGame
+ test/effects003/input view
@@ -0,0 +1,10 @@+a+e+i+o+f+c+s+p+r+t
+ test/effects003/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ hangman.idr -p effects -o hangman+./hangman < input+rm -f hangman *.ibc
test/error003/ErrorReflection.idr view
@@ -3,6 +3,7 @@ import Language.Reflection import Language.Reflection.Errors import Language.Reflection.Utils+import Data.Vect %language ErrorReflection
test/error003/expected view
@@ -1,2 +1,2 @@-ErrorReflection.idr:67:5:When elaborating right hand side of bad:-DSL type error: (t(502) => t'(503)) doesn't match ()+ErrorReflection.idr:68:5:When elaborating right hand side of bad:+DSL type error: (t(503) => t'(504)) doesn't match ()
+ test/error005/error005.idr view
@@ -0,0 +1,20 @@+module error005++import Data.Fin++-- Test the Prelude's error rewrites for Fin++one : Fin 2+one = 1++two : Fin 2+two = 2++hahaha : (n : Nat) -> Fin n+hahaha n = 0++ok : (n : Nat) -> Fin (plus 2 n)+ok n = 1++notOk : (n : Nat) -> Fin (plus 2 n)+notOk n = 2
+ test/error005/expected view
@@ -0,0 +1,12 @@+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+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:+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)
+ test/error005/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --check --nocolour error005.idr+rm -f *.ibc
+ test/idrisdoc009/Test.idr view
@@ -0,0 +1,45 @@+||| Docs for module Test.+|||+||| It is a great module.+||| Prelude thingy:+||| ```idris example+||| "foo" ++ "bar"+||| ```+|||+||| Imported thingy:+||| ```idris example+||| 0.0 :+ 0.2+||| ```+|||+||| Type error:+||| ```idris+||| "foo" + 2+||| ```+|||+||| From this module:+||| ```idris example+||| MkTest+||| ```+module Test+import Data.Complex++myplus : Nat -> Nat -> Nat+myplus Z j = j+myplus (S k) j = S (myplus k j)++||| Docs for datatype Test.+data Test = MkTest++data Thing : Type -> Type where+ MkThing : Thing Nat++-- fnord ++ xyz do done let module argh++namespace Main+ ||| Main is handy to do things in. ++. + main : IO ()+ main = do putStrLn "Hi!"+ l <- getLine+ case l of+ "" => putStrLn "No!"+ str => putStrLn str
+ test/idrisdoc009/expected view
@@ -0,0 +1,29 @@+Type checking ./Test.idr+Data type Test : Type+ Docs for datatype Test.+ +Constructors:+ MkTest : Test+ + +Module Test:+ Docs for module Test.+ + It is a great module. Prelude thingy:+ + > "foo" ++ "bar"+ "foobar"+ + Imported thingy:+ + > 0.0 :+ 0.2+ 0.0 :+ 0.2+ + Type error:+ + "foo" + 2+ + From this module:+ + > MkTest+ MkTest
+ test/idrisdoc009/input view
@@ -0,0 +1,2 @@+:consolewidth infinite+:doc Test
+ test/idrisdoc009/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --nocolour --quiet Test.idr < input+rm -f *.ibc
test/interactive001/input view
@@ -1,6 +1,6 @@-:cs 11 xs-:cs 17 ys-:ps 21 maprhs-:mw 25 isElem2-:cs 30 p-:cs 35 xs'+:cs 12 xs+:cs 18 ys+:ps 22 maprhs+:mw 26 isElem2+:cs 31 p+:cs 36 xs'
test/interactive001/test032.idr view
@@ -1,6 +1,7 @@ module elem import Decidable.Equality+import Data.Vect using (xs : List a) data Elem : a -> List a -> Type where
test/interactive002/input view
@@ -1,11 +1,11 @@-:ps 2 foo_arg1-:ps 2 foo_arg2-:ps 2 foo_arg3-:ps 2 foo_ret-:ps 6 bar_out-:ps 9 plus_in1-:ps 9 plus_out-:ps 13 what-:ps 16 ifoo_arg1-:ps 16 ifoo_out+:ps 3 foo_arg1+:ps 3 foo_arg2+:ps 3 foo_arg3+:ps 3 foo_ret+:ps 7 bar_out+:ps 10 plus_in1+:ps 10 plus_out+:ps 14 what+:ps 17 ifoo_arg1+:ps 17 ifoo_out
test/interactive002/interactive002.idr view
@@ -1,3 +1,4 @@+import Data.Vect foo : ?foo_arg1 -> ?foo_arg2 -> ?foo_arg3 -> ?foo_ret foo (S a) b c = plus (a + b + c) 42
test/interactive003/input view
@@ -1,4 +1,4 @@-:ps 2 app_rhs_1-:ps 3 app_rhs_2-:ps 6 vzipWith_rhs_3-:ps 7 vzipWith_rhs_1+:ps 4 app_rhs_1+:ps 5 app_rhs_2+:ps 8 vzipWith_rhs_3+:ps 9 vzipWith_rhs_1
test/interactive003/interactive003.idr view
@@ -1,3 +1,5 @@+import Data.Vect+ app : Vect n a -> Vect m a -> Vect (n + m) a app [] ys = ?app_rhs_1 app (x :: xs) ys = ?app_rhs_2
test/interactive004/input view
@@ -1,2 +1,2 @@-:ref 2 foo_rhs1 plus -:ref 6 append_rhs1 append+:ref 4 foo_rhs1 plus +:ref 8 append_rhs1 append
test/interactive004/interactive004.idr view
@@ -1,3 +1,5 @@+import Data.Vect+ foo : Nat -> Nat -> Nat foo k j = ?foo_rhs1
test/io003/test018a.idr view
@@ -1,5 +1,6 @@ module Main +import System import System.Concurrency.Process ping : ProcID String -> ProcID String -> Process String ()
test/primitives003/test038.idr view
@@ -1,5 +1,8 @@ module Main +import Data.Vect+import Data.Fin+ test : DecEq a => a -> a -> Bool test i1 i2 with (decEq i1 i2) test i1 i1 | Yes Refl = True
test/proof001/test029.idr view
@@ -1,14 +1,18 @@ module simple +import Data.Vect+ plus_comm : (n : Nat) -> (m : Nat) -> (n + m = m + n) -- Base case-(Z + m = m + Z) <== plus_comm =+-- (Z + m = m + Z) <== plus_comm = -- broken by typecase check+plus_comm Z m = rewrite ((m + Z = m) <== plusZeroRightNeutral) ==> (Z + m = m) in Refl -- Step case-(S k + m = m + S k) <== plus_comm =+-- (S k + m = m + S k) <== plus_comm =+plus_comm (S k) m = rewrite ((k + m = m + k) <== plus_comm) in rewrite ((S (m + k) = m + S k) <== plusSuccRightSucc) in Refl
test/proof002/Reflect.idr view
@@ -1,6 +1,7 @@ module Reflect import Decidable.Equality+ %default total using (xs : List a, ys : List a, G : List (List a))
test/proof002/expected view
@@ -1,4 +1,4 @@-Reflect.idr:207: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)
test/proof003/test015.idr view
@@ -106,9 +106,9 @@ -- There is almost certainly an easier proof. I don't care, for now :) Main.adc_lemma_2 = proof {- intro c,w,v,bit0,num0;- intro b0,v1,bit1,num1,b1;- intro bc,x,x1,bX,bX1;+ intro w,v,num0,bit0+ intro b0,v1,num1,bit1,b1+ intro c,bc,x,bX,x1,bX1 rewrite sym (plusZeroRightNeutral x); rewrite sym (plusZeroRightNeutral v1); rewrite sym (plusZeroRightNeutral (plus (plus x v) v1));
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) (UN MkPair) (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) (UN Pair) 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 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 (App (P (DCon 0 4) (UN MkPair) (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) (UN Pair) Erased) (V 3)) (V 2))))))) (TType (UVar 42))) (TType (UVar 44))) (App (App (App (App (P (DCon 0 4) (UN MkPair) (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) (UN Pair) 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) (UN MkPair) (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) (UN Pair) 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))) (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))))
test/quasiquote002/GoalQQuote.idr view
@@ -1,5 +1,6 @@ module GoalQQuote +import Data.Vect import Language.Reflection import Language.Reflection.Utils
test/quasiquote003/NoInfer.idr view
@@ -2,6 +2,7 @@ import Language.Reflection import Language.Reflection.Utils+import Data.Fin zzz2 : TT zzz2 = `(FZ : Fin 3)
test/quasiquote003/expected view
@@ -1,2 +1,2 @@-NoInfer.idr:10:5:When elaborating right hand side of zzz:+NoInfer.idr:11:5:When elaborating right hand side of zzz: No such variable k
test/records001/test011.idr view
@@ -1,5 +1,7 @@ module Main +import Data.Vect+ record Foo : Nat -> Type where MkFoo : (name : String) -> (things : Vect n a) ->
− test/reg002/reg002.idr
@@ -1,31 +0,0 @@-module Main--%default total--data CoNat- = Co Nat- | Infinity--S : CoNat -> CoNat-S (Co n) = Co (S n)-S Infinity = Infinity--Sn_notzero : Main.S n = Co 0 -> Void-Sn_notzero = believe_me--S_Co_not_Inf : Main.S (Co n) = Infinity -> Void-S_Co_not_Inf = believe_me--S_inj : (n : CoNat) -> (m : CoNat) -> Main.S n = Main.S m -> n = m-S_inj (Co n) (Co _) Refl = Refl-S_inj (Co n) Infinity p = void (S_Co_not_Inf p)-S_inj Infinity (Co m) p = void (S_Co_not_Inf (sym p))-S_inj Infinity Infinity Refl = Refl--swap : {n : Nat} -> Vect n a -> Vect n a-swap Nil = Nil-swap (x :: Nil) = x :: Nil-swap (x :: y :: xs) = (y :: x :: (swap xs))--main : IO ()-main = print (swap [1,2,3,4,5])
+ test/reg002/reg012.idr view
@@ -0,0 +1,33 @@+module Main++import Data.Vect++%default total++data CoNat+ = Co Nat+ | Infinity++S : CoNat -> CoNat+S (Co n) = Co (S n)+S Infinity = Infinity++Sn_notzero : Main.S n = Co 0 -> Void+Sn_notzero = believe_me++S_Co_not_Inf : Main.S (Co n) = Infinity -> Void+S_Co_not_Inf = believe_me++S_inj : (n : CoNat) -> (m : CoNat) -> Main.S n = Main.S m -> n = m+S_inj (Co n) (Co _) Refl = Refl+S_inj (Co n) Infinity p = void (S_Co_not_Inf p)+S_inj Infinity (Co m) p = void (S_Co_not_Inf (sym p))+S_inj Infinity Infinity Refl = Refl++swap : {n : Nat} -> Vect n a -> Vect n a+swap Nil = Nil+swap (x :: Nil) = x :: Nil+swap (x :: y :: xs) = (y :: x :: (swap xs))++main : IO ()+main = print (swap [1,2,3,4,5])
test/reg002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris reg002.idr -o reg002-./reg002-rm -f reg002 *.ibc+idris reg012.idr -o reg012+./reg012+rm -f reg012 *.ibc
+ test/reg005/reg005.idr view
@@ -0,0 +1,12 @@+module reg032++import Data.Fin++zfin : Fin 1+zfin = 0++data Infer = MkInf a++foo : Infer+foo = MkInf (the (Fin 1) 0)+
− test/reg005/reg032.idr
@@ -1,10 +0,0 @@-module reg032--zfin : Fin 1-zfin = 0--data Infer = MkInf a--foo : Infer-foo = MkInf (the (Fin 1) 0)-
test/reg005/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg032.idr --check+idris $@ reg005.idr --check rm -f *.ibc
test/reg009/reg009.lidr view
@@ -1,3 +1,6 @@+> import Data.So+> import Data.Vect+ > isAnyBy : (alpha -> Bool) -> (n : Nat ** Vect n alpha) -> Bool > isAnyBy _ (_ ** Nil) = False > isAnyBy p (_ ** (a :: as)) = p a || isAnyBy p (_ ** as)
test/reg010/expected view
@@ -1,11 +1,2 @@-reg010.idr:5:15:When elaborating right hand side of with block in usubst.unsafeSubst:-Can't unify- P x-with- P y--Specifically:- Can't unify- P x- with- P y+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/reg011/reg011.idr view
@@ -1,3 +1,5 @@+import Data.Vect+ vfoldl : (P : Nat -> Type) -> ((x : Nat) -> P x -> a -> P (S x)) -> P Z -> Vect m a -> P m
test/reg012/reg012.lidr view
@@ -1,7 +1,9 @@+> import Data.So+ > total soElim : (C : (b : Bool) -> So b -> Type) -> > C True Oh -> > (b : Bool) -> (s : So b) -> (C b s)-> soElim C coh .True .Oh = coh+> soElim C coh True Oh = coh > soFalseElim : So False -> a > soFalseElim x = void (soElim C () False x)
test/reg014/reg014.idr view
@@ -1,5 +1,7 @@ module reg014 +import Data.Vect+ Matrix : Type -> Nat -> Nat -> Type Matrix a n m = Vect n (Vect m a)
test/reg018/expected view
@@ -1,5 +1,5 @@ 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:19:1:CodataTest.inf is possibly not total due to: with block in CodataTest.inf-reg018d.idr:5:1:Main.pull is not total as there are missing cases+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/reg018c.idr view
@@ -1,4 +1,6 @@ module CodataTest+import Data.Vect+ %default total codata InfStream a = (::) a (InfStream a)
test/reg018/reg018d.idr view
@@ -1,5 +1,8 @@ module Main +import Data.Vect+import Data.Fin+ total pull : Fin (S n) -> Vect (S n) a -> (a, Vect n a) pull {n=Z} _ (x :: xs) = (x, xs)
test/reg020/reg020.idr view
@@ -1,5 +1,7 @@ module Main +import Data.Vect+ emptyString : String emptyString = ""
test/reg023/expected view
@@ -3,9 +3,3 @@ [94mNat[0m with [92mf[0m [94mNat[0m--Specifically:- Can't unify- [94mNat[0m- with- [92mf[0m [94mNat[0m
test/reg025/reg025.idr view
@@ -1,5 +1,7 @@ module Main +import Data.Fin+import Data.Vect import Data.Vect.Quantifiers import Decidable.Equality @@ -24,13 +26,13 @@ indexStep : {i : Fin n} -> {xs : Vect n a} -> {x : a} -> index i xs = index (FS i) (x::xs) indexStep = Refl -find : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a)- -> Either (All (\x => Not (P x)) xs) (y : a ** (P y, (i : Fin n ** y = index i xs)))+find : {p : a -> Type} -> ((x : a) -> Dec (p x)) -> (xs : Vect n a)+ -> Either (All (\x => Not (p x)) xs) (y : a ** (p y, (i : Fin n ** y = index i xs))) find _ Nil = Left Nil-find {P} d (x::xs) with (d x)+find {p} d (x::xs) with (d x) | Yes prf = Right (x ** (prf, (FZ ** Refl))) | No prf =- case find {P} d xs of+ case find {p} d xs of Right (y ** (prf', (i ** prf''))) => Right (y ** (prf', (FS i ** replace {P=(\x => y = x)} (indexStep {x=x}) prf''))) Left prf' => Left (prf::prf')@@ -41,7 +43,7 @@ findEmptyInRow : (xs : Vect n (Cell n)) -> Either (All Filled xs) (i : Fin n ** Empty (index i xs)) findEmptyInRow xs =- case find {P=Empty} empty xs of+ case find {p=Empty} empty xs of Right (_ ** (pempty, (i ** pidx))) => Right (i ** trans pempty pidx) Left p => Left p
test/reg026/reg026.idr view
@@ -1,5 +1,7 @@ module Test +import Data.So+ X : Nat -> Type X t = (c : Nat ** So (c < 5))
test/reg033/reg033.idr view
@@ -1,3 +1,5 @@+import Data.Vect+ mapFilter : (alpha -> beta) -> (alpha -> Bool) -> Vect n alpha ->
test/reg034/expected view
@@ -1,24 +1,4 @@ reg034.idr:6:5:When elaborating left hand side of bar:-When elaborating an application of main.bar:- Can't unify- [92mlength[0m ys [94m=[0m [92mlength[0m ys- with- [92mlength[0m [95mxs[0m [94m=[0m [92mlength[0m ys- - Specifically:- Can't unify- [92mlength[0m ys- with- [92mlength[0m [95mxs[0m+Can't match on bar xs xs [91mRefl[0m reg034.idr:9:5:When elaborating left hand side of foo:-When elaborating an application of main.foo:- Can't unify- [95mf[0m y [94m=[0m [95mf[0m y- with- [95mf[0m [95mx[0m [94m=[0m [95mf[0m y- - Specifically:- Can't unify- [95mf[0m y- with- [95mf[0m [95mx[0m+Can't match on foo f x x [91mRefl[0m
test/reg035/expected view
@@ -1,4 +1,4 @@-reg035b.idr:7:6:Can't convert+reg035b.idr:8:6:Can't convert [94mAdditive[0m -> [94mNat[0m with [94mFin[0m [91m0[0m
test/reg035/reg035a.lidr view
@@ -1,5 +1,7 @@ > module Set +> import Data.So+ > %default total > postulate soAndIntro : (p : alpha -> Bool) ->
test/reg035/reg035b.idr view
@@ -1,4 +1,5 @@ import Data.Vect+import Data.Fin total finZEmpty : Fin Z -> a
test/reg050/expected view
@@ -14,10 +14,11 @@ a terminator, expected: "$", "$>", "&&", "*", "+", "++", "-", "->", ".", "/", "/=", "::", ";",- "<", "<$", "<$>", "<*>", "<+>",- "<->", "<<", "<=", "<|>", "=",- "==", ">", ">=", ">>", ">>=",- "\\\\", "`", "in", "||", "~=~",+ "<", "<#>", "<$", "<$>", "<*>",+ "<+>", "<->", "<<", "<=", "<|>",+ "=", "==", ">", ">=", ">>",+ ">>=", "\\\\", "`", "in", "||",+ "~=~", ambiguous use of a left-associative operator, ambiguous use of a non-associative operator, ambiguous use of a right-associative operator,
+ test/reg054/expected view
@@ -0,0 +1,10 @@+reg054.idr:18:5:When elaborating left hand side of inf:+When elaborating an application of constructor [91mMain.MkInfer[0m:+ Attempting concrete match on polymorphic argument: 0+reg054.idr:34:7:When elaborating left hand side of weird:+When elaborating argument [95mx[0m to Main.weird:+ No explicit types on left hand side: Char+reg054.idr:37:9:Can't convert+ [94mMaybe[0m a1+with+ [95ma[0m
+ test/reg054/reg054.idr view
@@ -0,0 +1,39 @@+-- Catch typecase++data Ty = MInt | Str++eval : Ty -> Type+eval MInt = Maybe Int +eval Str = String++tcok : (x : Ty) -> eval x -> Int+tcok MInt (Just x) = x+tcok Str "foo" = 42+tcok Str x = 100++data Infer : Type where+ MkInfer : (a : Type) -> a -> Infer++inf : Infer -> Bool+inf (MkInfer _ Z) = True+inf (MkInfer _ (S k)) = False++data InfView : Infer -> Type where+ INat : (x : Nat) -> InfView (MkInfer Nat x)++foo : (i : Infer) -> InfView i -> Nat+foo (MkInfer _ _) (INat Z) = Z+foo (MkInfer _ _) (INat (S k)) = k++data Weird : Type -> Type where+ WInt : Int -> Weird Int+ WStr : String -> Weird String+ WBot : Weird Void++weird : Weird x -> x+weird {x = Char} y = '5'++tctrick : a -> Int+tctrick (Just x) = x+tctrick Nothing = 42+
+ test/reg054/run view
@@ -0,0 +1,2 @@+#!/usr/bin/env bash+idris $@ reg054.idr --check
+ test/reg055/expected view
@@ -0,0 +1,9 @@+reg055.idr:5:3:When elaborating left hand side of g:+Can't match on g ([92mf[0m [91m0[0m)+reg055.idr:8:3:When elaborating left hand side of h:+Can't match on h x x+reg055a.idr:8:5:When elaborating left hand side of foo:+When elaborating an application of constructor [91mFoo.CAny[0m:+ Attempting concrete match on polymorphic argument: Nothing+reg055a.idr:13:7:When elaborating left hand side of Foo.apply:+Can't match on apply (\[95mx[0m => \[95my[0m => [95mx[0m) a
+ test/reg055/reg055.idr view
@@ -0,0 +1,26 @@+f : Nat -> Nat +f Z = Z ++g : Nat -> Nat +g (f Z) = 1 ++h : Int -> Int -> Int+h x x = x++data Parity : Nat -> Type where+ Even : Parity (n + n)+ Odd : Parity (S (n + n))++foo : (n : Nat) -> Parity n -> Bool+foo (plus k k) Even = False+foo (S (plus k k)) Odd = True++data EqualLists : List () -> List () -> Type where+ EL : EqualLists l l++shouldWork : (l1,l2:List ()) -> EqualLists l1 l2 -> Bool+shouldWork [] [] EL = ?shouldWork_rhs_2+shouldWork (x :: xs) (x :: xs) EL = ?shouldWork_rhs_3++-- shouldWork [] [] EL = ?x_1+-- shouldWork (x :: xs) (x :: xs) EL = ?x_2
+ test/reg055/reg055a.idr view
@@ -0,0 +1,15 @@+module Foo++data Cheat : Type -> Type where+ CAny : a -> Cheat a+ CInt : Cheat Int++foo : Cheat a -> Int+foo (CAny Nothing) = 42 +foo (CAny (Just x)) = 43 +foo CInt = 0 ++apply : (a -> a -> b) -> a -> a+apply (\x => \y => x) a = a+apply f a = a +
+ test/reg055/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+idris $@ reg055.idr --check+idris $@ reg055a.idr --check+rm -f *.ibc+
+ test/reg056/expected view
@@ -0,0 +1,2 @@+reg056.idr:7:7:dodgy n m Refl is a valid case+reg056.idr:10:6:nonk Refl is a valid case
+ test/reg056/reg056.idr view
@@ -0,0 +1,15 @@+k : (a : Type) -> (x, y : a) -> (p, q : x = y) -> p = q+k a x x Refl Refl = Refl++postulate trap : Z = Z++dodgy : (a, b : ()) -> a = b -> Void+dodgy n m Refl impossible++nonk : (trap = Refl {Z}) -> Void+nonk Refl impossible++false : Void+false = nonk (k Nat Z Z trap Refl)++
+ test/reg056/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ reg056.idr -o reg056+rm -f *.ibc
+ test/reg057/expected view
+ test/reg057/reg057.idr view
@@ -0,0 +1,8 @@+module Foo++data CrappySet : (a : Type) -> Ord a -> Type where+ Empty : (inst : Ord a) => CrappySet a inst+ Item : (inst : Ord a) => a -> CrappySet a inst -> CrappySet a inst++empty : (inst : Ord a) => CrappySet a inst+
+ test/reg057/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ reg057.idr --check+rm -f *.ibc
test/runtest.pl view
@@ -2,17 +2,32 @@ use strict; use Cwd;+use Cwd 'abs_path';+use Env; my $exitstatus = 0; my @idrOpts = (); +sub sandbox_path {+ my ($test_dir,) = @_;+ my $sandbox = abs_path("$test_dir/../../.cabal-sandbox/bin");++ if ( -d $sandbox ) {+ return "PATH=$sandbox:$PATH";+ } else {+ return "";+ }+}+ sub runtest { my ($test, $update) = @_; + my $sandbox = sandbox_path($test);+ chdir($test); print "Running $test...\n";- my $got = `./run @idrOpts`;+ my $got = `$sandbox ./run @idrOpts`; my $exp = `cat expected`; open my $out, '>', 'output';@@ -62,6 +77,7 @@ } } @tests = sort @tests;+ } elsif ($test eq "without") { @args = @ARGV; foreach my $file (@args) {
+ test/sourceLocation001/SourceLoc.idr view
@@ -0,0 +1,100 @@+module SourceLoc++import Data.Vect+import Data.Fin+import Language.Reflection+import Language.Reflection.Utils++%default total++||| A "function" that returns where it is called in the source+getLoc : {default tactics { sourceLocation } x : SourceLocation} -> SourceLocation+getLoc {x} = x++||| A test of getLoc+fromRHS : SourceLocation+fromRHS = getLoc++||| Testing getting source locations from RHS proof scripts+fromProofScript : SourceLocation+fromProofScript = proof sourceLocation++||| Testing getting source locations from deferred proofs.+fromMetavar : SourceLocation+fromMetavar = ?meta++--- Testing that getting source locations in ASTs constructed with DSL notation+data Ty = U | Arr Ty Ty++interp : Ty -> Type+interp U = ()+interp (Arr x y) = interp x -> Either SourceLocation (interp y)++using (ctxt : Vect n Ty)+ data Tm : Vect n Ty -> Ty -> Type where+ MkU : Tm ctxt U+ 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+ Die : {default tactics { sourceLocation } loc : SourceLocation} -> Tm ctxt t++ data Env : Vect n Ty -> Type where+ Nil : Env []+ (::) : interp t -> Env ctxt -> Env (t::ctxt)++ index : (i : Fin n) -> Env ctxt -> interp (index i ctxt)+ index FZ (x::env) = x+ index (FS i) (x::env) = index i env++ run : Tm ctxt t -> Env ctxt -> Either SourceLocation (interp t)+ run MkU _ = pure ()+ run (Var i) env = pure $ index i env+ run (Lam bdy) env = pure $ \x => run bdy (x::env)+ run (App f x) env = !(run f env) !(run x env)+ run (Die {loc}) _ = Left loc+++exec : Tm [] t -> IO ()+exec tm = case run tm [] of+ Left loc => putStrLn $ "Error at " ++ show loc+ Right _ => putStrLn $ "Success!"++dsl lang+ variable = Var+ index_first = FZ+ index_next = FS+ lambda = Lam++testTerm1 : Tm [] (Arr U U)+testTerm1 = lang (\x=>Die)++testTerm2 : Tm [] U+testTerm2 = App testTerm1 MkU++testTerm3 : Tm [] (Arr U U)+testTerm3 = lang (\x => MkU)++testTerm4 : Tm [] U+testTerm4 = App testTerm3 MkU++namespace Main+ main : IO ()+ main = do putStrLn "Testing using definition"+ print fromRHS+ putStrLn "Testing using inline tactics"+ print fromProofScript+ putStrLn "Testing using metavariable with later definition"+ print fromMetavar+ putStrLn "-----------------------"+ sequence_ $ with List [ exec testTerm1+ , exec testTerm2+ , exec testTerm3+ , exec testTerm4+ ]+---------- Proofs ----------+SourceLoc.meta = proof+ sourceLocation+++
+ test/sourceLocation001/expected view
@@ -0,0 +1,11 @@+Testing using definition+FileLoc "SourceLoc.idr" (16, 11) (16, 11)+Testing using inline tactics+FileLoc "SourceLoc.idr" (20, 17) (20, 17)+Testing using metavariable with later definition+FileLoc "SourceLoc.idr" (96, 16) (96, 16)+-----------------------+Success!+Error at FileLoc "SourceLoc.idr" (70, 23) (70, 23)+Success!+Success!
+ test/sourceLocation001/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ SourceLoc.idr -o sourceLocation001+./sourceLocation001+rm -f sourceLocation001 *.ibc
+ test/sugar004/expected view
@@ -0,0 +1,3 @@+No arguments!+42+Too many arguments!
+ test/sugar004/run view
@@ -0,0 +1,6 @@+#!/usr/bin/env bash+idris $@ sugar004.idr -o sugar004+./sugar004+./sugar004 42+./sugar004 42 100+rm -f sugar004 *.ibc
+ test/sugar004/sugar004.idr view
@@ -0,0 +1,36 @@+module Main++import System++total+foo : Maybe Int -> Int+foo x = let Just x' = x | Nothing => 100 in x'++main : IO ()+main = do [p, a] <- getArgs | [p] => putStrLn "No arguments!"+ | (x :: y :: _) => putStrLn "Too many arguments!"+ print (foo (Just (cast a)))++{-++let pat = val | <alternatives> in x'++...becomes...++case val of+ pat => x'+ <alternatives>++do pat <- val | <alternatives>+ p++...becomes...++do x <- val+ case x of+ pat => p+ <alternatives>++-}++
+ test/sugar005/As.idr view
@@ -0,0 +1,36 @@+module As++-- Test @+isS : Nat -> Maybe Nat+isS Z = Nothing+isS n@(S _) = Just n++-- Test @ under a constructor+hasS : List Nat -> Maybe Nat+hasS (Z::xs) = hasS xs+hasS (n@(S_)::xs) = Just n+hasS _ = Nothing++-- Test nested @s+isSS : Nat -> Maybe (Nat, Nat)+isSS n@(S m@(S _)) = Just (n,m)+isSS _ = Nothing++-- Test two @-patterns+same : Nat -> Nat -> Maybe Nat+same x@(S _) y@(S _) = Just $ x + y+same Z Z = Just 42+same _ _ = Nothing++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+
+ test/sugar005/expected view
@@ -0,0 +1,9 @@+Nothing+Just 1+Nothing+Just 1+Just (5, 4)+Nothing+Just 2+Just 42+Nothing
+ test/sugar005/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ As.idr -o sugar005+./sugar005+rm -f sugar005 *.ibc
test/totality001/expected view
@@ -1,3 +1,3 @@-test010.idr:13:1:Main.foo 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/test010.idr view
@@ -1,3 +1,5 @@+import Data.Vect+ data MyNat = MyO | MyS MyNat %default total
test/totality002/expected view
@@ -1,2 +1,2 @@-test017a.idr:5:1:scg.vtrans is possibly not total due to recursive path scg.vtrans --> scg.vtrans+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/test017.idr view
@@ -1,5 +1,7 @@ module scg +import Data.Vect+ %default total data Ord = Zero | Suc Ord | Sup (Nat -> Ord)
test/totality002/test017a.idr view
@@ -1,5 +1,7 @@ module scg +import Data.Vect+ total vtrans : Vect n a -> Vect n a -> List a vtrans [] _ = []
test/totality006/expected view
@@ -1,2 +1,2 @@-totality006.idr:6:1:Main.prf is not total as there are missing cases-totality006a.idr:9:6:prf' (S _) (S _) Oh is a valid case+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
test/totality006/totality006.idr view
@@ -1,3 +1,5 @@+import Data.So+ antitrue : So False -> a antitrue Oh impossible @@ -6,6 +8,6 @@ prf Z Z Oh impossible prf Z (S k) um = antitrue um prf (S k) Z um = LTESucc LTEZero --- prf (S _) (S _) Oh impossible+-- prf (S x) (S y) Oh impossible
test/totality006/totality006a.idr view
@@ -1,3 +1,5 @@+import Data.So+ antitrue : So False -> a antitrue Oh impossible
test/tutorial006/expected view
@@ -1,5 +1,5 @@-tutorial006a.idr:3:23:When elaborating right hand side of vapp:-When elaborating argument [95mxs[0m to constructor [91mPrelude.Vect.::[0m:+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 with
test/tutorial006/tutorial006a.idr view
@@ -1,3 +1,5 @@+import Data.Vect+ vapp : Vect n a -> Vect m a -> Vect (n + m) a vapp Nil ys = ys vapp (x :: xs) ys = x :: vapp xs xs -- BROKEN