mirror of
https://github.com/idris-lang/Idris2.git
synced 2024-12-25 20:51:43 +03:00
Experiment %syntactic flag on with
This means it abstracts over the value syntactically, rather than by value, and can significantly speed up elaboration where large types are involved, at a cost of being less general. Try it if "with" is slow. There are more flags we want on with (well, at least one: "proof")
This commit is contained in:
parent
1d87e3cd18
commit
d869eb666c
@ -18,10 +18,12 @@ newIORef val
|
|||||||
= do m <- primIO (prim__newIORef val)
|
= do m <- primIO (prim__newIORef val)
|
||||||
pure (MkRef m)
|
pure (MkRef m)
|
||||||
|
|
||||||
|
%inline
|
||||||
export
|
export
|
||||||
readIORef : IORef a -> IO a
|
readIORef : IORef a -> IO a
|
||||||
readIORef (MkRef m) = primIO (prim__readIORef m)
|
readIORef (MkRef m) = primIO (prim__readIORef m)
|
||||||
|
|
||||||
|
%inline
|
||||||
export
|
export
|
||||||
writeIORef : IORef a -> (1 val : a) -> IO ()
|
writeIORef : IORef a -> (1 val : a) -> IO ()
|
||||||
writeIORef (MkRef m) val = primIO (prim__writeIORef m val)
|
writeIORef (MkRef m) val = primIO (prim__writeIORef m val)
|
||||||
|
@ -373,6 +373,7 @@ interface Num ty => Integral ty where
|
|||||||
|
|
||||||
-- Integer
|
-- Integer
|
||||||
|
|
||||||
|
%inline
|
||||||
public export
|
public export
|
||||||
Num Integer where
|
Num Integer where
|
||||||
(+) = prim__add_Integer
|
(+) = prim__add_Integer
|
||||||
@ -408,6 +409,7 @@ defaultInteger = %search
|
|||||||
|
|
||||||
-- Int
|
-- Int
|
||||||
|
|
||||||
|
%inline
|
||||||
public export
|
public export
|
||||||
Num Int where
|
Num Int where
|
||||||
(+) = prim__add_Int
|
(+) = prim__add_Int
|
||||||
@ -914,11 +916,13 @@ public export
|
|||||||
Right x == Right x' = x == x'
|
Right x == Right x' = x == x'
|
||||||
_ == _ = False
|
_ == _ = False
|
||||||
|
|
||||||
|
%inline
|
||||||
public export
|
public export
|
||||||
Functor (Either e) where
|
Functor (Either e) where
|
||||||
map f (Left x) = Left x
|
map f (Left x) = Left x
|
||||||
map f (Right x) = Right (f x)
|
map f (Right x) = Right (f x)
|
||||||
|
|
||||||
|
%inline
|
||||||
public export
|
public export
|
||||||
Applicative (Either e) where
|
Applicative (Either e) where
|
||||||
pure = Right
|
pure = Right
|
||||||
|
@ -499,11 +499,11 @@ mutual
|
|||||||
(case ws of
|
(case ws of
|
||||||
[] => rhs'
|
[] => rhs'
|
||||||
_ => ILocal fc (concat ws) rhs')
|
_ => ILocal fc (concat ws) rhs')
|
||||||
desugarClause ps arg (MkWithClause fc lhs wval cs)
|
desugarClause ps arg (MkWithClause fc lhs wval flags cs)
|
||||||
= do cs' <- traverse (desugarClause ps arg) cs
|
= do cs' <- traverse (desugarClause ps arg) cs
|
||||||
(bound, blhs) <- bindNames arg !(desugar LHS ps lhs)
|
(bound, blhs) <- bindNames arg !(desugar LHS ps lhs)
|
||||||
wval' <- desugar AnyExpr (bound ++ ps) wval
|
wval' <- desugar AnyExpr (bound ++ ps) wval
|
||||||
pure $ WithClause fc blhs wval' cs'
|
pure $ WithClause fc blhs wval' flags cs'
|
||||||
desugarClause ps arg (MkImpossible fc lhs)
|
desugarClause ps arg (MkImpossible fc lhs)
|
||||||
= do dlhs <- desugar LHS ps lhs
|
= do dlhs <- desugar LHS ps lhs
|
||||||
pure $ ImpossibleClause fc (snd !(bindNames arg dlhs))
|
pure $ ImpossibleClause fc (snd !(bindNames arg dlhs))
|
||||||
@ -624,8 +624,8 @@ mutual
|
|||||||
toIDef : ImpClause -> Core ImpDecl
|
toIDef : ImpClause -> Core ImpDecl
|
||||||
toIDef (PatClause fc lhs rhs)
|
toIDef (PatClause fc lhs rhs)
|
||||||
= pure $ IDef fc !(getFn lhs) [PatClause fc lhs rhs]
|
= pure $ IDef fc !(getFn lhs) [PatClause fc lhs rhs]
|
||||||
toIDef (WithClause fc lhs rhs cs)
|
toIDef (WithClause fc lhs rhs flags cs)
|
||||||
= pure $ IDef fc !(getFn lhs) [WithClause fc lhs rhs cs]
|
= pure $ IDef fc !(getFn lhs) [WithClause fc lhs rhs flags cs]
|
||||||
toIDef (ImpossibleClause fc lhs)
|
toIDef (ImpossibleClause fc lhs)
|
||||||
= pure $ IDef fc !(getFn lhs) [ImpossibleClause fc lhs]
|
= pure $ IDef fc !(getFn lhs) [ImpossibleClause fc lhs]
|
||||||
|
|
||||||
|
@ -403,10 +403,10 @@ elabImplementation {vars} fc vis opts_in pass env nest is cons iname ps impln nu
|
|||||||
updateClause ns (PatClause fc lhs rhs)
|
updateClause ns (PatClause fc lhs rhs)
|
||||||
= do lhs' <- updateApp ns lhs
|
= do lhs' <- updateApp ns lhs
|
||||||
pure (PatClause fc lhs' rhs)
|
pure (PatClause fc lhs' rhs)
|
||||||
updateClause ns (WithClause fc lhs wval cs)
|
updateClause ns (WithClause fc lhs wval flags cs)
|
||||||
= do lhs' <- updateApp ns lhs
|
= do lhs' <- updateApp ns lhs
|
||||||
cs' <- traverse (updateClause ns) cs
|
cs' <- traverse (updateClause ns) cs
|
||||||
pure (WithClause fc lhs' wval cs')
|
pure (WithClause fc lhs' wval flags cs')
|
||||||
updateClause ns (ImpossibleClause fc lhs)
|
updateClause ns (ImpossibleClause fc lhs)
|
||||||
= do lhs' <- updateApp ns lhs
|
= do lhs' <- updateApp ns lhs
|
||||||
pure (ImpossibleClause fc lhs')
|
pure (ImpossibleClause fc lhs')
|
||||||
|
@ -395,9 +395,9 @@ elabInterface {vars} fc vis env nest constraints iname params dets mcon body
|
|||||||
changeName : Name -> ImpClause -> ImpClause
|
changeName : Name -> ImpClause -> ImpClause
|
||||||
changeName dn (PatClause fc lhs rhs)
|
changeName dn (PatClause fc lhs rhs)
|
||||||
= PatClause fc (changeNameTerm dn lhs) rhs
|
= PatClause fc (changeNameTerm dn lhs) rhs
|
||||||
changeName dn (WithClause fc lhs wval cs)
|
changeName dn (WithClause fc lhs wval flags cs)
|
||||||
= WithClause fc (changeNameTerm dn lhs) wval
|
= WithClause fc (changeNameTerm dn lhs) wval
|
||||||
(map (changeName dn) cs)
|
flags (map (changeName dn) cs)
|
||||||
changeName dn (ImpossibleClause fc lhs)
|
changeName dn (ImpossibleClause fc lhs)
|
||||||
= ImpossibleClause fc (changeNameTerm dn lhs)
|
= ImpossibleClause fc (changeNameTerm dn lhs)
|
||||||
|
|
||||||
|
@ -858,6 +858,13 @@ tyDecl fname indents
|
|||||||
atEnd indents
|
atEnd indents
|
||||||
pure (MkPTy (MkFC fname start end) n ty)
|
pure (MkPTy (MkFC fname start end) n ty)
|
||||||
|
|
||||||
|
withFlags : SourceEmptyRule (List WithFlag)
|
||||||
|
withFlags
|
||||||
|
= do pragma "syntactic"
|
||||||
|
fs <- withFlags
|
||||||
|
pure $ Syntactic :: fs
|
||||||
|
<|> pure []
|
||||||
|
|
||||||
mutual
|
mutual
|
||||||
parseRHS : (withArgs : Nat) ->
|
parseRHS : (withArgs : Nat) ->
|
||||||
FileName -> FilePos -> Int ->
|
FileName -> FilePos -> Int ->
|
||||||
@ -872,11 +879,12 @@ mutual
|
|||||||
pure (MkPatClause (MkFC fname start end) lhs rhs ws)
|
pure (MkPatClause (MkFC fname start end) lhs rhs ws)
|
||||||
<|> do keyword "with"
|
<|> do keyword "with"
|
||||||
wstart <- location
|
wstart <- location
|
||||||
|
flags <- withFlags
|
||||||
symbol "("
|
symbol "("
|
||||||
wval <- bracketedExpr fname wstart indents
|
wval <- bracketedExpr fname wstart indents
|
||||||
ws <- nonEmptyBlock (clause (S withArgs) fname)
|
ws <- nonEmptyBlock (clause (S withArgs) fname)
|
||||||
end <- location
|
end <- location
|
||||||
pure (MkWithClause (MkFC fname start end) lhs wval ws)
|
pure (MkWithClause (MkFC fname start end) lhs wval flags ws)
|
||||||
<|> do keyword "impossible"
|
<|> do keyword "impossible"
|
||||||
atEnd indents
|
atEnd indents
|
||||||
end <- location
|
end <- location
|
||||||
|
@ -188,7 +188,7 @@ printClause l i (PatClause _ lhsraw rhsraw)
|
|||||||
= do lhs <- pterm lhsraw
|
= do lhs <- pterm lhsraw
|
||||||
rhs <- pterm rhsraw
|
rhs <- pterm rhsraw
|
||||||
pure (relit l (pack (replicate i ' ') ++ show lhs ++ " = " ++ show rhs))
|
pure (relit l (pack (replicate i ' ') ++ show lhs ++ " = " ++ show rhs))
|
||||||
printClause l i (WithClause _ lhsraw wvraw csraw)
|
printClause l i (WithClause _ lhsraw wvraw flags csraw)
|
||||||
= do lhs <- pterm lhsraw
|
= do lhs <- pterm lhsraw
|
||||||
wval <- pterm wvraw
|
wval <- pterm wvraw
|
||||||
cs <- traverse (printClause l (i + 2)) csraw
|
cs <- traverse (printClause l (i + 2)) csraw
|
||||||
|
@ -312,9 +312,10 @@ mutual
|
|||||||
= pure (MkPatClause fc !(toPTerm startPrec lhs)
|
= pure (MkPatClause fc !(toPTerm startPrec lhs)
|
||||||
!(toPTerm startPrec rhs)
|
!(toPTerm startPrec rhs)
|
||||||
[])
|
[])
|
||||||
toPClause (WithClause fc lhs rhs cs)
|
toPClause (WithClause fc lhs rhs flags cs)
|
||||||
= pure (MkWithClause fc !(toPTerm startPrec lhs)
|
= pure (MkWithClause fc !(toPTerm startPrec lhs)
|
||||||
!(toPTerm startPrec rhs)
|
!(toPTerm startPrec rhs)
|
||||||
|
flags
|
||||||
!(traverse toPClause cs))
|
!(traverse toPClause cs))
|
||||||
toPClause (ImpossibleClause fc lhs)
|
toPClause (ImpossibleClause fc lhs)
|
||||||
= pure (MkImpossible fc !(toPTerm startPrec lhs))
|
= pure (MkImpossible fc !(toPTerm startPrec lhs))
|
||||||
|
@ -145,7 +145,7 @@ mutual
|
|||||||
MkPatClause : FC -> (lhs : PTerm) -> (rhs : PTerm) ->
|
MkPatClause : FC -> (lhs : PTerm) -> (rhs : PTerm) ->
|
||||||
(whereblock : List PDecl) -> PClause
|
(whereblock : List PDecl) -> PClause
|
||||||
MkWithClause : FC -> (lhs : PTerm) -> (wval : PTerm) ->
|
MkWithClause : FC -> (lhs : PTerm) -> (wval : PTerm) ->
|
||||||
List PClause -> PClause
|
List WithFlag -> List PClause -> PClause
|
||||||
MkImpossible : FC -> (lhs : PTerm) -> PClause
|
MkImpossible : FC -> (lhs : PTerm) -> PClause
|
||||||
|
|
||||||
public export
|
public export
|
||||||
@ -350,7 +350,7 @@ showCount = elimSemi
|
|||||||
mutual
|
mutual
|
||||||
showAlt : PClause -> String
|
showAlt : PClause -> String
|
||||||
showAlt (MkPatClause _ lhs rhs _) = " | " ++ show lhs ++ " => " ++ show rhs ++ ";"
|
showAlt (MkPatClause _ lhs rhs _) = " | " ++ show lhs ++ " => " ++ show rhs ++ ";"
|
||||||
showAlt (MkWithClause _ lhs wval cs) = " | <<with alts not possible>>;"
|
showAlt (MkWithClause _ lhs wval flags cs) = " | <<with alts not possible>>;"
|
||||||
showAlt (MkImpossible _ lhs) = " | " ++ show lhs ++ " impossible;"
|
showAlt (MkImpossible _ lhs) = " | " ++ show lhs ++ " impossible;"
|
||||||
|
|
||||||
showDo : PDo -> String
|
showDo : PDo -> String
|
||||||
@ -403,7 +403,7 @@ mutual
|
|||||||
where
|
where
|
||||||
showAlt : PClause -> String
|
showAlt : PClause -> String
|
||||||
showAlt (MkPatClause _ lhs rhs _) = " | " ++ show lhs ++ " => " ++ show rhs ++ ";"
|
showAlt (MkPatClause _ lhs rhs _) = " | " ++ show lhs ++ " => " ++ show rhs ++ ";"
|
||||||
showAlt (MkWithClause _ lhs rhs _) = " | <<with alts not possible>>"
|
showAlt (MkWithClause _ lhs rhs flags _) = " | <<with alts not possible>>"
|
||||||
showAlt (MkImpossible _ lhs) = " | " ++ show lhs ++ " impossible;"
|
showAlt (MkImpossible _ lhs) = " | " ++ show lhs ++ " impossible;"
|
||||||
showPrec _ (PCase _ tm cs)
|
showPrec _ (PCase _ tm cs)
|
||||||
= "case " ++ show tm ++ " of { " ++
|
= "case " ++ show tm ++ " of { " ++
|
||||||
@ -411,7 +411,7 @@ mutual
|
|||||||
where
|
where
|
||||||
showCase : PClause -> String
|
showCase : PClause -> String
|
||||||
showCase (MkPatClause _ lhs rhs _) = show lhs ++ " => " ++ show rhs
|
showCase (MkPatClause _ lhs rhs _) = show lhs ++ " => " ++ show rhs
|
||||||
showCase (MkWithClause _ lhs rhs _) = " | <<with alts not possible>>"
|
showCase (MkWithClause _ lhs rhs flags _) = " | <<with alts not possible>>"
|
||||||
showCase (MkImpossible _ lhs) = show lhs ++ " impossible"
|
showCase (MkImpossible _ lhs) = show lhs ++ " impossible"
|
||||||
showPrec d (PLocal _ ds sc) -- We'll never see this when displaying a normal form...
|
showPrec d (PLocal _ ds sc) -- We'll never see this when displaying a normal form...
|
||||||
= "let { << definitions >> } in " ++ showPrec d sc
|
= "let { << definitions >> } in " ++ showPrec d sc
|
||||||
@ -810,9 +810,10 @@ mapPTermM f = goPTerm where
|
|||||||
MkPatClause fc <$> goPTerm lhs
|
MkPatClause fc <$> goPTerm lhs
|
||||||
<*> goPTerm rhs
|
<*> goPTerm rhs
|
||||||
<*> goPDecls wh
|
<*> goPDecls wh
|
||||||
goPClause (MkWithClause fc lhs wVal cls) =
|
goPClause (MkWithClause fc lhs wVal flags cls) =
|
||||||
MkWithClause fc <$> goPTerm lhs
|
MkWithClause fc <$> goPTerm lhs
|
||||||
<*> goPTerm wVal
|
<*> goPTerm wVal
|
||||||
|
<*> pure flags
|
||||||
<*> goPClauses cls
|
<*> goPClauses cls
|
||||||
goPClause (MkImpossible fc lhs) = MkImpossible fc <$> goPTerm lhs
|
goPClause (MkImpossible fc lhs) = MkImpossible fc <$> goPTerm lhs
|
||||||
|
|
||||||
|
@ -328,11 +328,11 @@ caseBlock {vars} rigc elabinfo fc nest env scr scrtm scrty caseRig alts expected
|
|||||||
(bindCaseLocals loc' (map getNestData (names nest))
|
(bindCaseLocals loc' (map getNestData (names nest))
|
||||||
(reverse ns) rhs)
|
(reverse ns) rhs)
|
||||||
-- With isn't allowed in a case block but include for completeness
|
-- With isn't allowed in a case block but include for completeness
|
||||||
updateClause casen splitOn nest env (WithClause loc' lhs wval cs)
|
updateClause casen splitOn nest env (WithClause loc' lhs wval flags cs)
|
||||||
= let (_, args) = addEnv 0 env (usedIn lhs)
|
= let (_, args) = addEnv 0 env (usedIn lhs)
|
||||||
args' = mkSplit splitOn lhs args
|
args' = mkSplit splitOn lhs args
|
||||||
lhs' = apply (IVar loc' casen) args' in
|
lhs' = apply (IVar loc' casen) args' in
|
||||||
WithClause loc' (applyNested nest lhs') wval cs
|
WithClause loc' (applyNested nest lhs') wval flags cs
|
||||||
updateClause casen splitOn nest env (ImpossibleClause loc' lhs)
|
updateClause casen splitOn nest env (ImpossibleClause loc' lhs)
|
||||||
= let (_, args) = addEnv 0 env (usedIn lhs)
|
= let (_, args) = addEnv 0 env (usedIn lhs)
|
||||||
args' = mkSplit splitOn lhs args
|
args' = mkSplit splitOn lhs args
|
||||||
|
@ -82,7 +82,7 @@ expandClause loc n c
|
|||||||
updateRHS : ImpClause -> RawImp -> ImpClause
|
updateRHS : ImpClause -> RawImp -> ImpClause
|
||||||
updateRHS (PatClause fc lhs _) rhs = PatClause fc lhs rhs
|
updateRHS (PatClause fc lhs _) rhs = PatClause fc lhs rhs
|
||||||
-- 'with' won't happen, include for completeness
|
-- 'with' won't happen, include for completeness
|
||||||
updateRHS (WithClause fc lhs wval cs) rhs = WithClause fc lhs wval cs
|
updateRHS (WithClause fc lhs wval flags cs) rhs = WithClause fc lhs wval flags cs
|
||||||
updateRHS (ImpossibleClause fc lhs) _ = ImpossibleClause fc lhs
|
updateRHS (ImpossibleClause fc lhs) _ = ImpossibleClause fc lhs
|
||||||
|
|
||||||
dropLams : {vars : _} ->
|
dropLams : {vars : _} ->
|
||||||
@ -143,7 +143,7 @@ generateSplits : {auto m : Ref MD Metadata} ->
|
|||||||
FC -> Int -> ImpClause ->
|
FC -> Int -> ImpClause ->
|
||||||
Core (List (Name, List ImpClause))
|
Core (List (Name, List ImpClause))
|
||||||
generateSplits loc fn (ImpossibleClause fc lhs) = pure []
|
generateSplits loc fn (ImpossibleClause fc lhs) = pure []
|
||||||
generateSplits loc fn (WithClause fc lhs wval cs) = pure []
|
generateSplits loc fn (WithClause fc lhs wval flags cs) = pure []
|
||||||
generateSplits {c} {m} {u} loc fn (PatClause fc lhs rhs)
|
generateSplits {c} {m} {u} loc fn (PatClause fc lhs rhs)
|
||||||
= do (lhstm, _) <-
|
= do (lhstm, _) <-
|
||||||
elabTerm fn (InLHS linear) [] (MkNested []) []
|
elabTerm fn (InLHS linear) [] (MkNested []) []
|
||||||
|
@ -502,7 +502,7 @@ mutual
|
|||||||
ws <- nonEmptyBlock (clause (S withArgs) fname)
|
ws <- nonEmptyBlock (clause (S withArgs) fname)
|
||||||
end <- location
|
end <- location
|
||||||
let fc = MkFC fname start end
|
let fc = MkFC fname start end
|
||||||
pure (!(getFn lhs), WithClause fc lhs wval (map snd ws))
|
pure (!(getFn lhs), WithClause fc lhs wval [] (map snd ws))
|
||||||
|
|
||||||
<|> do keyword "impossible"
|
<|> do keyword "impossible"
|
||||||
atEnd indents
|
atEnd indents
|
||||||
|
@ -78,14 +78,10 @@ export
|
|||||||
impossibleErrOK : {auto c : Ref Ctxt Defs} ->
|
impossibleErrOK : {auto c : Ref Ctxt Defs} ->
|
||||||
Defs -> Error -> Core Bool
|
Defs -> Error -> Core Bool
|
||||||
impossibleErrOK defs (CantConvert fc env l r)
|
impossibleErrOK defs (CantConvert fc env l r)
|
||||||
= do logTerm 10 "Impossible" !(normalise defs env l)
|
= impossibleOK defs !(nf defs env l)
|
||||||
logTerm 10 " ...and" !(normalise defs env r)
|
|
||||||
impossibleOK defs !(nf defs env l)
|
|
||||||
!(nf defs env r)
|
!(nf defs env r)
|
||||||
impossibleErrOK defs (CantSolveEq fc env l r)
|
impossibleErrOK defs (CantSolveEq fc env l r)
|
||||||
= do logTerm 10 "Impossible" !(normalise defs env l)
|
= impossibleOK defs !(nf defs env l)
|
||||||
logTerm 10 " ...and" !(normalise defs env r)
|
|
||||||
impossibleOK defs !(nf defs env l)
|
|
||||||
!(nf defs env r)
|
!(nf defs env r)
|
||||||
impossibleErrOK defs (BadDotPattern _ _ ErasedArg _ _) = pure True
|
impossibleErrOK defs (BadDotPattern _ _ ErasedArg _ _) = pure True
|
||||||
impossibleErrOK defs (CyclicMeta _ _ _ _) = pure True
|
impossibleErrOK defs (CyclicMeta _ _ _ _) = pure True
|
||||||
@ -122,14 +118,10 @@ export
|
|||||||
recoverableErr : {auto c : Ref Ctxt Defs} ->
|
recoverableErr : {auto c : Ref Ctxt Defs} ->
|
||||||
Defs -> Error -> Core Bool
|
Defs -> Error -> Core Bool
|
||||||
recoverableErr defs (CantConvert fc env l r)
|
recoverableErr defs (CantConvert fc env l r)
|
||||||
= do logTerm 10 "Impossible" !(normalise defs env l)
|
= recoverable defs !(nf defs env l)
|
||||||
logTerm 10 " ...and" !(normalise defs env r)
|
|
||||||
recoverable defs !(nf defs env l)
|
|
||||||
!(nf defs env r)
|
!(nf defs env r)
|
||||||
recoverableErr defs (CantSolveEq fc env l r)
|
recoverableErr defs (CantSolveEq fc env l r)
|
||||||
= do logTerm 10 "Impossible" !(normalise defs env l)
|
= recoverable defs !(nf defs env l)
|
||||||
logTerm 10 " ...and" !(normalise defs env r)
|
|
||||||
recoverable defs !(nf defs env l)
|
|
||||||
!(nf defs env r)
|
!(nf defs env r)
|
||||||
recoverableErr defs (BadDotPattern _ _ ErasedArg _ _) = pure True
|
recoverableErr defs (BadDotPattern _ _ ErasedArg _ _) = pure True
|
||||||
recoverableErr defs (CyclicMeta _ _ _ _) = pure True
|
recoverableErr defs (CyclicMeta _ _ _ _) = pure True
|
||||||
@ -453,7 +445,7 @@ checkClause {vars} mult hashit n opts nest env (PatClause fc lhs_in rhs)
|
|||||||
|
|
||||||
pure (Right (MkClause env' lhstm' rhstm))
|
pure (Right (MkClause env' lhstm' rhstm))
|
||||||
-- TODO: (to decide) With is complicated. Move this into its own module?
|
-- TODO: (to decide) With is complicated. Move this into its own module?
|
||||||
checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs)
|
checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw flags cs)
|
||||||
= do (lhs, (vars' ** (sub', env', nest', lhspat, reqty))) <-
|
= do (lhs, (vars' ** (sub', env', nest', lhspat, reqty))) <-
|
||||||
checkLHS False mult hashit n opts nest env fc lhs_in
|
checkLHS False mult hashit n opts nest env fc lhs_in
|
||||||
let wmode
|
let wmode
|
||||||
@ -492,9 +484,12 @@ checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs
|
|||||||
let notreqns = fst bnr
|
let notreqns = fst bnr
|
||||||
let notreqty = snd bnr
|
let notreqty = snd bnr
|
||||||
|
|
||||||
wtyScope <- replace defs scenv !(nf defs scenv (weaken wval))
|
rdefs <- if Syntactic `elem` flags
|
||||||
|
then clearDefs defs
|
||||||
|
else pure defs
|
||||||
|
wtyScope <- replace rdefs scenv !(nf rdefs scenv (weaken wval))
|
||||||
(Local fc (Just False) _ First)
|
(Local fc (Just False) _ First)
|
||||||
!(nf defs scenv
|
!(nf rdefs scenv
|
||||||
(weaken {n=wargn} notreqty))
|
(weaken {n=wargn} notreqty))
|
||||||
let bNotReq = Bind fc wargn (Pi top Explicit wvalTy) wtyScope
|
let bNotReq = Bind fc wargn (Pi top Explicit wvalTy) wtyScope
|
||||||
|
|
||||||
@ -567,11 +562,11 @@ checkClause {vars} mult hashit n opts nest env (WithClause fc lhs_in wval_raw cs
|
|||||||
= do newlhs <- getNewLHS ploc drop nest wname wargnames lhs patlhs
|
= do newlhs <- getNewLHS ploc drop nest wname wargnames lhs patlhs
|
||||||
newrhs <- withRHS ploc drop wname wargnames rhs lhs
|
newrhs <- withRHS ploc drop wname wargnames rhs lhs
|
||||||
pure (PatClause ploc newlhs newrhs)
|
pure (PatClause ploc newlhs newrhs)
|
||||||
mkClauseWith drop wname wargnames lhs (WithClause ploc patlhs rhs ws)
|
mkClauseWith drop wname wargnames lhs (WithClause ploc patlhs rhs flags ws)
|
||||||
= do newlhs <- getNewLHS ploc drop nest wname wargnames lhs patlhs
|
= do newlhs <- getNewLHS ploc drop nest wname wargnames lhs patlhs
|
||||||
newrhs <- withRHS ploc drop wname wargnames rhs lhs
|
newrhs <- withRHS ploc drop wname wargnames rhs lhs
|
||||||
ws' <- traverse (mkClauseWith (S drop) wname wargnames lhs) ws
|
ws' <- traverse (mkClauseWith (S drop) wname wargnames lhs) ws
|
||||||
pure (WithClause ploc newlhs newrhs ws')
|
pure (WithClause ploc newlhs newrhs flags ws')
|
||||||
mkClauseWith drop wname wargnames lhs (ImpossibleClause ploc patlhs)
|
mkClauseWith drop wname wargnames lhs (ImpossibleClause ploc patlhs)
|
||||||
= do newlhs <- getNewLHS ploc drop nest wname wargnames lhs patlhs
|
= do newlhs <- getNewLHS ploc drop nest wname wargnames lhs patlhs
|
||||||
pure (ImpossibleClause ploc newlhs)
|
pure (ImpossibleClause ploc newlhs)
|
||||||
|
@ -292,10 +292,19 @@ mutual
|
|||||||
" " ++ show con ++ "\n\t" ++
|
" " ++ show con ++ "\n\t" ++
|
||||||
showSep "\n\t" (map show fields) ++ "\n"
|
showSep "\n\t" (map show fields) ++ "\n"
|
||||||
|
|
||||||
|
public export
|
||||||
|
data WithFlag
|
||||||
|
= Syntactic -- abstract syntactically, rather than by value
|
||||||
|
|
||||||
|
export
|
||||||
|
Eq WithFlag where
|
||||||
|
Syntactic == Syntactic = True
|
||||||
|
|
||||||
public export
|
public export
|
||||||
data ImpClause : Type where
|
data ImpClause : Type where
|
||||||
PatClause : FC -> (lhs : RawImp) -> (rhs : RawImp) -> ImpClause
|
PatClause : FC -> (lhs : RawImp) -> (rhs : RawImp) -> ImpClause
|
||||||
WithClause : FC -> (lhs : RawImp) -> (wval : RawImp) ->
|
WithClause : FC -> (lhs : RawImp) -> (wval : RawImp) ->
|
||||||
|
(flags : List WithFlag) ->
|
||||||
List ImpClause -> ImpClause
|
List ImpClause -> ImpClause
|
||||||
ImpossibleClause : FC -> (lhs : RawImp) -> ImpClause
|
ImpossibleClause : FC -> (lhs : RawImp) -> ImpClause
|
||||||
|
|
||||||
@ -303,7 +312,7 @@ mutual
|
|||||||
Show ImpClause where
|
Show ImpClause where
|
||||||
show (PatClause fc lhs rhs)
|
show (PatClause fc lhs rhs)
|
||||||
= show lhs ++ " = " ++ show rhs
|
= show lhs ++ " = " ++ show rhs
|
||||||
show (WithClause fc lhs wval block)
|
show (WithClause fc lhs wval flags block)
|
||||||
= show lhs ++ " with " ++ show wval ++ "\n\t" ++ show block
|
= show lhs ++ " with " ++ show wval ++ "\n\t" ++ show block
|
||||||
show (ImpossibleClause fc lhs)
|
show (ImpossibleClause fc lhs)
|
||||||
= show lhs ++ " impossible"
|
= show lhs ++ " impossible"
|
||||||
@ -835,7 +844,7 @@ mutual
|
|||||||
= do tag 0; toBuf b fc; toBuf b lhs; toBuf b rhs
|
= do tag 0; toBuf b fc; toBuf b lhs; toBuf b rhs
|
||||||
toBuf b (ImpossibleClause fc lhs)
|
toBuf b (ImpossibleClause fc lhs)
|
||||||
= do tag 1; toBuf b fc; toBuf b lhs
|
= do tag 1; toBuf b fc; toBuf b lhs
|
||||||
toBuf b (WithClause fc lhs wval cs)
|
toBuf b (WithClause fc lhs wval flags cs)
|
||||||
= do tag 2; toBuf b fc; toBuf b lhs; toBuf b wval; toBuf b cs
|
= do tag 2; toBuf b fc; toBuf b lhs; toBuf b wval; toBuf b cs
|
||||||
|
|
||||||
fromBuf b
|
fromBuf b
|
||||||
@ -847,7 +856,7 @@ mutual
|
|||||||
pure (ImpossibleClause fc lhs)
|
pure (ImpossibleClause fc lhs)
|
||||||
2 => do fc <- fromBuf b; lhs <- fromBuf b;
|
2 => do fc <- fromBuf b; lhs <- fromBuf b;
|
||||||
wval <- fromBuf b; cs <- fromBuf b
|
wval <- fromBuf b; cs <- fromBuf b
|
||||||
pure (WithClause fc lhs wval cs)
|
pure (WithClause fc lhs wval [] cs)
|
||||||
_ => corrupt "ImpClause"
|
_ => corrupt "ImpClause"
|
||||||
|
|
||||||
export
|
export
|
||||||
|
@ -150,11 +150,11 @@ mutual
|
|||||||
++ bound in
|
++ bound in
|
||||||
PatClause fc (substNames [] [] lhs)
|
PatClause fc (substNames [] [] lhs)
|
||||||
(substNames bound' ps rhs)
|
(substNames bound' ps rhs)
|
||||||
substNamesClause bound ps (WithClause fc lhs wval cs)
|
substNamesClause bound ps (WithClause fc lhs wval flags cs)
|
||||||
= let bound' = map UN (map snd (findBindableNames True bound [] lhs))
|
= let bound' = map UN (map snd (findBindableNames True bound [] lhs))
|
||||||
++ bound in
|
++ bound in
|
||||||
WithClause fc (substNames [] [] lhs)
|
WithClause fc (substNames [] [] lhs)
|
||||||
(substNames bound' ps wval) cs
|
(substNames bound' ps wval) flags cs
|
||||||
substNamesClause bound ps (ImpossibleClause fc lhs)
|
substNamesClause bound ps (ImpossibleClause fc lhs)
|
||||||
= ImpossibleClause fc (substNames bound [] lhs)
|
= ImpossibleClause fc (substNames bound [] lhs)
|
||||||
|
|
||||||
@ -230,9 +230,10 @@ mutual
|
|||||||
substLocClause fc' (PatClause fc lhs rhs)
|
substLocClause fc' (PatClause fc lhs rhs)
|
||||||
= PatClause fc' (substLoc fc' lhs)
|
= PatClause fc' (substLoc fc' lhs)
|
||||||
(substLoc fc' rhs)
|
(substLoc fc' rhs)
|
||||||
substLocClause fc' (WithClause fc lhs wval cs)
|
substLocClause fc' (WithClause fc lhs wval flags cs)
|
||||||
= WithClause fc' (substLoc fc' lhs)
|
= WithClause fc' (substLoc fc' lhs)
|
||||||
(substLoc fc' wval)
|
(substLoc fc' wval)
|
||||||
|
flags
|
||||||
(map (substLocClause fc') cs)
|
(map (substLocClause fc') cs)
|
||||||
substLocClause fc' (ImpossibleClause fc lhs)
|
substLocClause fc' (ImpossibleClause fc lhs)
|
||||||
= ImpossibleClause fc' (substLoc fc' lhs)
|
= ImpossibleClause fc' (substLoc fc' lhs)
|
||||||
|
@ -8,7 +8,7 @@
|
|||||||
0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 18) (:end 7 21)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:265}_[] ?{_:264}_[])")))))) 1)
|
0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 18) (:end 7 21)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:265}_[] ?{_:264}_[])")))))) 1)
|
||||||
0000d8(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 16) (:end 7 1)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect m a)")))))) 1)
|
0000d8(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 16) (:end 7 1)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect m a)")))))) 1)
|
||||||
0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 11) (:end 6 14)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:254}_[] ?{_:253}_[])")))))) 1)
|
0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 11) (:end 6 14)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:254}_[] ?{_:253}_[])")))))) 1)
|
||||||
0001ca(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 6 1)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Nat} -> {0 a : Type} -> {0 n : Prelude.Nat} -> (({arg:244} : (Main.Vect n[0] a[1])) -> (({arg:245} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.+ Prelude.Nat Prelude.Num implementation at Prelude.idr:759:1--766:1 n[2] m[4]) a[3])))")))))) 1)
|
0001ca(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 6 1)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Nat} -> {0 a : Type} -> {0 n : Prelude.Nat} -> (({arg:244} : (Main.Vect n[0] a[1])) -> (({arg:245} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.+ Prelude.Nat Prelude.Num implementation at Prelude.idr:761:1--768:1 n[2] m[4]) a[3])))")))))) 1)
|
||||||
0000cb(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 47) (:end 6 1)) ((:name "a") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Type")))))) 1)
|
0000cb(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 47) (:end 6 1)) ((:name "a") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Type")))))) 1)
|
||||||
0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 44) (:end 5 45)) ((:name "m") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)
|
0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 44) (:end 5 45)) ((:name "m") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)
|
||||||
0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 40) (:end 5 42)) ((:name "n") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)
|
0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 40) (:end 5 42)) ((:name "n") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)
|
||||||
|
@ -8,7 +8,7 @@
|
|||||||
0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 18) (:end 7 21)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:265}_[] ?{_:264}_[])")))))) 1)
|
0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 18) (:end 7 21)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:265}_[] ?{_:264}_[])")))))) 1)
|
||||||
0000d8(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 16) (:end 7 1)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect m a)")))))) 1)
|
0000d8(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 16) (:end 7 1)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect m a)")))))) 1)
|
||||||
0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 11) (:end 6 14)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:254}_[] ?{_:253}_[])")))))) 1)
|
0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 11) (:end 6 14)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:254}_[] ?{_:253}_[])")))))) 1)
|
||||||
0001ca(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 6 1)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Nat} -> {0 a : Type} -> {0 n : Prelude.Nat} -> (({arg:244} : (Main.Vect n[0] a[1])) -> (({arg:245} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.+ Prelude.Nat Prelude.Num implementation at Prelude.idr:759:1--766:1 n[2] m[4]) a[3])))")))))) 1)
|
0001ca(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 6 1)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Nat} -> {0 a : Type} -> {0 n : Prelude.Nat} -> (({arg:244} : (Main.Vect n[0] a[1])) -> (({arg:245} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.+ Prelude.Nat Prelude.Num implementation at Prelude.idr:761:1--768:1 n[2] m[4]) a[3])))")))))) 1)
|
||||||
0000cb(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 47) (:end 6 1)) ((:name "a") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Type")))))) 1)
|
0000cb(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 47) (:end 6 1)) ((:name "a") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Type")))))) 1)
|
||||||
0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 44) (:end 5 45)) ((:name "m") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)
|
0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 44) (:end 5 45)) ((:name "m") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)
|
||||||
0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 40) (:end 5 42)) ((:name "n") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)
|
0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 40) (:end 5 42)) ((:name "n") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)
|
||||||
|
Loading…
Reference in New Issue
Block a user