module Lib.ProcessDecl import Prelude import Data.IORef import Data.String import Lib.Common import Lib.Elab import Lib.Parser import Lib.Syntax import Data.SortedMap import Lib.TopContext import Lib.Eval import Lib.Prettier import Lib.Types import Lib.Util import Lib.Erasure dumpEnv : Context -> M String dumpEnv ctx = unlines ∘ reverse <$> go (names ctx) 0 (reverse $ zip ctx.env ctx.types) Nil where isVar : Int -> Val -> Bool isVar k (VVar _ k' Lin) = k == k' isVar _ _ = False go : List String -> Int -> List (Val × String × Val) -> List String -> M (List String) go _ _ Nil acc = pure acc go names k ((v, n, ty) :: xs) acc = if isVar k v -- TODO - use Doc and add <+/> as appropriate to printing then do ty' <- quote ctx.lvl ty go names (1 + k) xs (" \{n} : \{render 90 $ pprint names ty'}":: acc) else do v' <- quote ctx.lvl v ty' <- quote ctx.lvl ty go names (1 + k) xs (" \{n} = \{render 90 $ pprint names v'} : \{render 90 $ pprint names ty'}":: acc) logMetas : List MetaEntry -> M Unit logMetas Nil = pure MkUnit logMetas (OutOfScope :: rest) = logMetas rest logMetas (Solved fc k soln :: rest) = logMetas rest logMetas (Unsolved fc k ctx ty User cons :: rest) = do ty' <- quote ctx.lvl ty let names = map fst ctx.types env <- dumpEnv ctx let msg = "\{env}\n -----------\n \{render 90 $ pprint names ty'}" info fc "User Hole\n\{msg}" logMetas rest logMetas (Unsolved fc k ctx ty kind cons :: rest) = do ty' <- forceMeta ty tm <- quote ctx.lvl ty' -- FIXME in Combinatory.newt, the val doesn't match environment? let msg = "Unsolved meta \{show k} \{show kind} type \{render 90 $ pprint (names ctx) tm} \{show $ length' cons} constraints" msgs <- for cons $ \case (MkMc fc env sp val) => do pure " * (m\{show k} (\{unwords $ map show $ sp <>> Nil}) =?= \{show val}" sols <- case kind of AutoSolve => do x <- quote ctx.lvl ty ty <- eval ctx.env x debug $ \ _ => "AUTO ---> \{show ty}" -- we want the context here too. top <- getTop let (VRef _ tyname _) = ty | _ => pure Nil let cands = fromMaybe Nil $ lookupMap' tyname top.hints matches <- findMatches ctx ty cands pure $ (" \{show $ length' matches} Solutions: \{show matches}" :: Nil) _ => pure Nil info fc $ unlines ((msg :: Nil) ++ msgs ++ sols) logMetas rest -- Used for Class and Record getSigs : List Decl -> List (FC × String × Raw) getSigs Nil = Nil getSigs ((TypeSig _ Nil _) :: xs) = getSigs xs getSigs ((TypeSig fc (nm :: nms) ty) :: xs) = (fc, nm, ty) :: getSigs xs getSigs (_ :: xs) = getSigs xs teleToPi : Telescope -> Raw -> Raw teleToPi Nil end = end teleToPi ((info, ty) :: tele) end = RPi (getFC info) info ty (teleToPi tele end) impTele : Telescope -> Telescope impTele tele = map foo tele where foo : BindInfo × Raw → BindInfo × Raw foo (BI fc nm _ _ , ty) = (BI fc nm Implicit Zero, ty) checkAlreadyDef : FC → Name → M Unit checkAlreadyDef fc nm = do top <- getTop case lookupRaw nm top of Nothing => pure MkUnit Just entry => error fc "\{show nm} is already defined at \{show entry.fc}" processDecl : List String -> Decl -> M Unit processTypeSig : List String → FC → List Name → Raw → M Unit processTypeSig ns fc names tm = do log 1 $ \ _ => "-----" top <- getTop let mc = top.metaCtx -- let mstart = length' mc.metas traverse (checkAlreadyDef fc) names ty <- check (mkCtx fc) tm (VU fc) -- this is not needed -- ty <- zonk top 0 Nil ty log 1 $ \ _ => "TypeSig \{unwords names} : \{render 90 $ pprint Nil ty}" ignore $ for names $ \nm => setDef (QN ns nm) fc ty Axiom Nil processPrimType : List Name → FC → Name → Maybe Raw → M Unit processPrimType ns fc nm ty = do top <- getTop ty' <- check (mkCtx fc) (maybe (RU fc) id ty) (VU fc) let arity = cast $ piArity ty' setDef (QN ns nm) fc ty' (PrimTCon arity) Nil processPrimFn : List String → FC → String → List String → Raw → String → M Unit processPrimFn ns fc nm used ty src = do top <- getTop ty <- check (mkCtx fc) ty (VU fc) ty' <- nf Nil ty log 1 $ \ _ => "pfunc \{nm} : \{render 90 $ pprint Nil ty'} = \{show src}" -- TODO wire through fc for not in scope error used' <- for used $ \ name => case lookupRaw name top of Nothing => error fc "\{name} not in scope" Just entry => pure entry.name let arity = piArity ty' setDef (QN ns nm) fc ty' (PrimFn src arity used') Nil -- Heuristic for whether a function is simple enough to inline -- I'm trying to get ++ and + inlined as javascript + complexity : Tm → Int complexity (Ref _ _) = 1 complexity (Meta _ _) = 1 -- what's a good score for this, it's not inlined yet. complexity (Lam _ _ _ _ sc) = 1 + complexity sc -- Ignore metas - they may be erased and likely are much smaller when substituted complexity (App _ t u) = go t (complexity u) where go : Tm → Int → Int go (App _ t u) acc = go t (acc + complexity u) go (Meta _ _) acc = 1 go t acc = acc + complexity t complexity (Bnd _ _) = 1 complexity (UU _) = 0 complexity (Lit _ _) = 0 -- These turn into a projection complexity (Case _ sc (CaseCons _ _ t :: Nil)) = 1 + complexity sc + complexity t complexity _ = 100 processDef : List String → FC → String → List (Raw × Raw) → M Unit processDef ns fc nm clauses = do log 1 $ \ _ => "-----" log 1 $ \ _ => "Def \{show nm}" top <- getTop let mc = top.metaCtx let (Just entry) = lookupRaw nm top | Nothing => throwError $ E fc "No declaration for \{nm}" let (MkEntry fc name ty Axiom _) = entry | _ => throwError $ E fc "\{nm} already defined at \{show entry.fc}" log 1 $ \ _ => "check \{nm} at \{render 90 $ pprint Nil ty}" vty <- eval Nil ty debug $ \ _ => "\{nm} vty is \{show vty}" clauses' <- traverse makeClause clauses tm <- buildTree (mkCtx fc) (MkProb clauses' vty) solveAutos -- This inlines metas and functions flagged Inline. -- moved to Compile.newt because it was interfering with type checking (Zoo4eg.newt) via over-reduction -- tm' <- zonk top 0 Nil tm debug $ \ _ => "Add def \{nm} \{render 90 $ pprint Nil tm} : \{render 90 $ pprint Nil ty}" updateDef (QN ns nm) fc ty (Fn tm) -- putStrLn "complexity \{show (QN ns nm)} \{show $ complexity tm}" -- putStrLn $ show tm -- TODO we need some protection against inlining a function calling itself. -- We need better heuristics, maybe fuel and deciding while inlining. -- IO,bind is explicit here because the complexity has a 100 in it. let name = show $ QN ns nm if complexity tm < 15 || name == "Prelude.Prelude.Monad Prelude.IO,bind" || name == "Prelude._>>=_" then setFlag (QN ns nm) fc Inline else pure MkUnit processCheck : List String → FC → Raw → Raw → M Unit processCheck ns fc tm ty = do log 1 $ \ _ => "----- DCheck" top <- getTop info fc "check \{show tm} at \{show ty}" ty' <- check (mkCtx fc) ty (VU fc) putStrLn " got type \{render 90 $ pprint Nil ty'}" vty <- eval Nil ty' res <- check (mkCtx fc) tm vty putStrLn " got \{render 90 $ pprint Nil res}" norm <- nf Nil res putStrLn " NF \{render 90 $ pprint Nil norm}" processClass : List String → FC → String → Telescope → List Decl → M Unit processClass ns classFC nm tele decls = do -- REVIEW maybe we can leverage Record for this -- a couple of catches, we don't want the dotted accessors and -- the self argument should be an auto-implicit log 1 $ \ _ => "-----" log 1 $ \ _ => "Class \{nm}" let fields = getSigs decls -- We'll need names for the telescope let dcName = "Mk\{nm}" let tcType = teleToPi tele (RU classFC) let tail = foldl mkApp (RVar classFC nm) tele let dcType = teleToPi (impTele tele) $ foldr mkPi tail fields log 1 $ \ _ => "tcon type \{render 90 $ pretty tcType}" log 1 $ \ _ => "dcon type \{render 90 $ pretty dcType}" let decl = Data classFC nm tcType (TypeSig classFC (dcName :: Nil) dcType :: Nil) log 1 $ \ _ => "Decl:" log 1 $ \ _ => render 90 $ pretty decl processDecl ns decl ignore $ for fields $ \case (fc,name,ty) => do let funType = teleToPi (impTele tele) $ RPi fc (BI fc "_" Auto Many) tail ty let autoPat = foldl mkAutoApp (RVar classFC dcName) fields let lhs = makeLHS (RVar fc name) tele let lhs = RApp classFC lhs autoPat Auto let decl = FunDef fc name ((lhs, (RVar fc name)) :: Nil) log 1 $ \ _ => "\{name} : \{render 90 $ pretty funType}" log 1 $ \ _ => "\{render 90 $ pretty decl}" processDecl ns $ TypeSig fc (name :: Nil) funType setFlag (QN ns name) fc Inline processDecl ns decl where makeLHS : Raw → Telescope → Raw makeLHS acc ((BI fc' nm icit quant, _) :: tele) = RApp fc' (makeLHS acc tele) (RVar fc' nm) Implicit makeLHS acc Nil = acc -- TODO probably should just do the fold ourselves then. mkAutoApp : Raw → FC × String × Raw → Raw mkAutoApp acc (fc, nm, ty) = RApp fc acc (RVar fc nm) Explicit mkPi : FC × String × Raw → Raw → Raw mkPi (fc, nm, ty) acc = RPi fc (BI fc nm Explicit Many) ty acc mkApp : Raw → BindInfo × Raw → Raw mkApp acc (BI fc nm icit _, _) = RApp fc acc (RVar fc nm) icit processInstance : List String → FC → Raw → Maybe (List Decl) → M Unit processInstance ns instfc ty decls = do log 1 $ \ _ => "-----" log 1 $ \ _ => "Instance \{render 90 $ pretty ty}" top <- getTop let tyFC = getFC ty vty <- check (mkCtx instfc) ty (VU instfc) -- Here `tele` holds arguments to the instance let (codomain, tele) = splitTele vty -- env represents the environment of those arguments let env = tenv (length tele) debug $ \ _ => "codomain \{render 90 $ pprint Nil codomain}" debug $ \ _ => "tele is \{show tele}" -- ok so we need a name, a hack for now. -- Maybe we need to ask the user (e.g. `instance someName : Monad Foo where`) -- or use "Monad\{show $ length' defs}" let instname = render 90 $ pprint Nil codomain let sigDecl = TypeSig instfc (instname :: Nil) ty -- This needs to be declared before processing the defs, but the defs need to be -- declared before this - side effect is that a duplicate def is noted at the first -- member case lookupRaw instname top of Just _ => pure MkUnit -- TODO check that the types match Nothing => do -- only add once processDecl ns sigDecl setFlag (QN ns instname) instfc Hint addHint (QN ns instname) let (Just decls) = collectDecl <$> decls | _ => do debug $ \ _ => "Forward declaration \{show sigDecl}" let (Ref _ tconName, args) = funArgs codomain | (tm, _) => error tyFC "\{render 90 $ pprint Nil codomain} doesn't appear to be a TCon application" let (Just (MkEntry _ name type (TCon _ cons) _)) = lookup tconName top | _ => error tyFC "\{show tconName} is not a type constructor" let (con :: Nil) = cons | _ => error tyFC "\{show tconName} has multiple constructors \{show cons}" let (Just (MkEntry _ _ dcty (DCon _ _ _ _) _)) = lookup con top | _ => error tyFC "can't find constructor \{show con}" vdcty@(VPi _ nm icit rig a b) <- eval Nil dcty | x => error (getFC x) "dcty not Pi" debug $ \ _ => "dcty \{render 90 $ pprint Nil dcty}" let (_,args) = funArgs codomain debug $ \ _ => "traverse \{show $ map showTm args}" -- This is a little painful because we're reverse engineering the -- individual types back out from the composite type args' <- traverse (eval env) args debug $ \ _ => "args' is \{show args'}" appty <- apply vdcty args' conTele <- getFields appty env Nil -- declare individual functions, collect their defs defs <- for conTele $ \case (MkBinder fc nm Explicit rig ty) => do let ty' = foldr (\ x acc => case the Binder x of (MkBinder fc nm' icit rig ty') => Pi fc nm' icit rig ty' acc) ty tele let nm' = "\{instname},\{nm}" -- we're working with a Tm, so we define directly instead of processDecl let (Just (FunDef fc name xs)) = find (\x => case the Decl x of (FunDef y name xs) => name == nm _ => False) decls | _ => error instfc "no definition for \{nm}" -- REVIEW if we want to Hint this setDef (QN ns nm') fc ty' Axiom Nil let decl = (FunDef fc nm' xs) log 1 $ \ _ => "***" log 1 $ \ _ => "«\{nm'}» : \{render 90 $ pprint Nil ty'}" log 1 $ \ _ => render 80 $ pretty decl pure $ Just decl _ => pure Nothing for (mapMaybe id defs) $ \decl => do -- debug because already printed above, but nice to have it near processing debug $ \ _ => render 80 $ pretty decl processDecl ns decl let (QN _ con') = con let decl = FunDef instfc instname ((RVar instfc instname, mkRHS instname conTele (RVar instfc con')) :: Nil) log 1 $ \ _ => "SIGDECL" log 1 $ \ _ => "\{render 90 $ pretty sigDecl}" log 1 $ \ _ => render 80 $ pretty decl processDecl ns decl where -- try to extract types of individual fields from the typeclass dcon -- We're assuming they don't depend on each other. getFields : Val -> Env -> List Binder -> M (List Binder) getFields tm@(VPi fc nm Explicit rig ty sc) env bnds = do bnd <- MkBinder fc nm Explicit rig <$> quote (length' env) ty appsc <- sc $$ VVar fc (length' env) Lin getFields appsc env (bnd :: bnds) getFields tm@(VPi fc nm _ rig ty sc) env bnds = do appsc <- sc $$ VVar fc (length' env) Lin getFields appsc env bnds getFields tm xs bnds = pure $ reverse bnds tenv : Nat -> Env tenv Z = Nil tenv (S k) = (VVar emptyFC (cast k) Lin :: tenv k) mkRHS : String -> List Binder -> Raw -> Raw mkRHS instName (MkBinder fc nm Explicit rig ty :: bs) tm = mkRHS instName bs (RApp fc tm (RVar fc "\{instName},\{nm}") Explicit) mkRHS instName (b :: bs) tm = mkRHS instName bs tm mkRHS instName Nil tm = tm apply : Val -> List Val -> M Val apply x Nil = pure x apply (VPi fc nm icit rig a b) (x :: xs) = do bx <- b $$ x apply bx xs apply x (y :: xs) = error instfc "expected pi type \{show x}" -- desugars to Data and processes it processShortData : List String → FC → Raw → List Raw → M Unit processShortData ns fc lhs sigs = do (nm,args) <- getArgs lhs Nil let ty = foldr mkPi (RU fc) args cons <- traverse (mkDecl args Nil) sigs let dataDecl = Data fc nm ty cons log 1 $ \ _ => "SHORTDATA" log 1 $ \ _ => "\{render 90 $ pretty dataDecl}" processDecl ns dataDecl where mkPi : FC × Name → Raw → Raw mkPi (fc,n) a = RPi fc (BI fc n Explicit Zero) (RU fc) a getArgs : Raw -> List (FC × String) -> M (String × List (FC × String)) getArgs (RVar fc1 nm) acc = pure (nm, acc) getArgs (RApp _ t (RVar fc' nm) _) acc = getArgs t ((fc', nm) :: acc) getArgs tm _ = error (getFC tm) "Expected contructor application, got: \{show tm}" mkDecl : List (FC × Name) -> List Raw -> Raw -> M Decl mkDecl args acc (RVar fc' name) = do let base = foldr (\ ty acc => RPi (getFC ty) (BI (getFC ty) "_" Explicit Many) ty acc) lhs acc let ty = foldr mkPi base args pure $ TypeSig fc' (name :: Nil) ty where mkPi : FC × String → Raw → Raw mkPi (fc,nm) acc = RPi fc (BI fc nm Implicit Zero) (RU fc) acc mkDecl args acc (RApp fc' t u icit) = mkDecl args (u :: acc) t mkDecl args acc tm = error (getFC tm) "Expected contructor application, got: \{show tm}" -- Identify Nat-like, enum-like, etc populateConInfo : List TopEntry → List TopEntry populateConInfo entries = let (Nothing) = traverse checkEnum entries -- Boolean | Just (a :: b :: Nil) => (setInfo a FalseCon :: setInfo b TrueCon :: Nil) | Just entries => entries in let (a :: b :: Nil) = entries | _ => entries in let (Just succ) = find isSucc entries | _ => entries in let (Just zero) = find isZero entries | _ => entries in setInfo zero ZeroCon :: setInfo succ SuccCon :: Nil where setInfo : TopEntry → ConInfo → TopEntry setInfo (MkEntry fc nm dty (DCon ix _ arity hn) flags) info = MkEntry fc nm dty (DCon ix info arity hn) flags setInfo x _ = x checkEnum : TopEntry → Maybe TopEntry checkEnum (MkEntry fc nm dty (DCon ix _ Nil hn) flags) = Just $ MkEntry fc nm dty (DCon ix EnumCon Nil hn) flags checkEnum _ = Nothing isZero : TopEntry → Bool isZero (MkEntry fc nm dty (DCon _ _ Nil hn) flags) = True isZero _ = False -- TODO - handle indexes, etc isSucc : TopEntry → Bool isSucc (MkEntry fc nm dty@(Pi _ _ _ _ (Ref _ a) (Ref _ b)) (DCon _ _ (Many :: Nil) hn) _) = a == b isSucc _ = False processData : List String → FC → String → Raw → List Decl → M Unit processData ns fc nm ty cons = do log 1 $ \ _ => "-----" log 1 $ \ _ => "Data \{nm}" top <- getTop let mc = top.metaCtx tyty <- check (mkCtx fc) ty (VU fc) case lookupRaw nm top of Just (MkEntry _ name type Axiom _) => do tyty' <- eval Nil tyty type' <- eval Nil type unifyCatch fc (mkCtx fc) tyty' type' Just _ => error fc "\{show nm} already declared" Nothing => setDef (QN ns nm) fc tyty Axiom Nil -- check cons, return list of type,con allCons <- join <$> (for cons $ \x => case x of (TypeSig fc names tm) => do traverse (checkAlreadyDef fc) names debug $ \ _ => "check dcon \{show names} \{show tm}" dty <- check (mkCtx fc) tm (VU fc) debug $ \ _ => "dty \{show names} is \{render 90 $ pprint Nil dty}" -- We only check that codomain used the right type constructor -- We know it's in U because it's part of a checked Pi type let (codomain, tele) = splitTele dty -- for printing let tnames = reverse $ map binderName tele let (Ref _ hn, args) = funArgs codomain | (tm, _) => error (getFC tm) "expected \{nm} got \{render 90 $ pprint tnames tm}" when (hn /= QN ns nm) $ \ _ => error (getFC codomain) "Constructor codomain is \{render 90 $ pprint tnames codomain} rather than \{nm}" pure $ map (_,_ dty) names decl => throwError $ E (getFC decl) "expected constructor declaration") -- type level autos like _++_ solveAutos let entries = populateConInfo $ map makeConEntry $ enumerate allCons for entries $ \case (MkEntry name fc dty def flags) => setDef fc name dty def flags let cnames = map (\x => x.name) entries log 1 $ \ _ => "setDef \{nm} TCon \{show cnames}" let arity = cast $ piArity tyty updateDef (QN ns nm) fc tyty (TCon arity cnames) where makeConEntry : (Nat × Tm × String) → TopEntry makeConEntry (ix, dty, nm') = MkEntry fc (QN ns nm') dty (DCon ix NormalCon (getArity dty) (QN ns nm)) Nil binderName : Binder → Name binderName (MkBinder _ nm _ _ _) = nm checkDeclType : Tm -> M Unit checkDeclType (UU _) = pure MkUnit checkDeclType (Pi _ str icit rig t u) = checkDeclType u checkDeclType _ = error fc "data type doesn't return U" processRecord : List String → FC → String → Telescope → Maybe Name → List Decl → M Unit processRecord ns recordFC nm tele cname decls = do log 1 $ \ _ => "-----" log 1 $ \ _ => "Record" let fields = getSigs decls let dcName = fromMaybe "Mk\{show nm}" cname let tcType = teleToPi tele (RU recordFC) -- REVIEW - I probably want to stick the telescope in front of the fields let tail = foldl (\ acc bi => case the (BindInfo × Raw) bi of (BI fc nm icit _, _) => RApp fc acc (RVar fc nm) icit) (RVar recordFC nm) tele let dcType = teleToPi (impTele tele) $ foldr (\ x acc => case the (FC × String × Raw) x of (fc, nm, ty) => RPi fc (BI fc nm Explicit Many) ty acc ) tail fields log 1 $ \ _ => "tcon type \{render 90 $ pretty tcType}" log 1 $ \ _ => "dcon type \{render 90 $ pretty dcType}" let decl = Data recordFC nm tcType (TypeSig recordFC (dcName :: Nil) dcType :: Nil) log 1 $ \ _ => "Decl:" log 1 $ \ _ => render 90 $ pretty decl processDecl ns decl ignore $ for fields $ \case (fc,name,ty) => do -- TODO dependency isn't handled yet -- we'll need to replace stuff like `len` with `len self`. let funType = teleToPi (impTele tele) $ RPi fc (BI fc "_" Explicit Many) tail ty let autoPat = foldl (\acc x => case the (FC × String × Raw) x of (fc,nm,ty) => RApp fc acc (RVar fc nm) Explicit) (RVar recordFC dcName) fields -- `.fieldName` let pname = "." ++ name let lhs = foldl (\acc x => case the (BindInfo × Raw) x of (BI fc' nm icit quant, _) => RApp fc' acc (RVar fc' nm) Implicit) (RVar fc pname) tele let lhs = RApp recordFC lhs autoPat Explicit let pdecl = FunDef fc pname ((lhs, (RVar fc name)) :: Nil) log 1 $ \ _ => "\{pname} : \{render 90 $ pretty funType}" log 1 $ \ _ => "\{render 90 $ pretty pdecl}" processDecl ns $ TypeSig fc (pname :: Nil) funType processDecl ns pdecl setFlag (QN ns pname) fc Inline -- currently mixfix registration is handled in the parser -- since we now run a decl at a time we could do it here. processDecl ns (PMixFix _ _ _ _) = pure MkUnit processDecl ns (TypeSig fc names tm) = processTypeSig ns fc names tm processDecl ns (PType fc nm ty) = processPrimType ns fc nm ty processDecl ns (PFunc fc nm used ty src) = processPrimFn ns fc nm used ty src processDecl ns (FunDef fc nm clauses) = processDef ns fc nm clauses processDecl ns (DCheck fc tm ty) = processCheck ns fc tm ty processDecl ns (Class classFC nm tele decls) = processClass ns classFC nm tele decls processDecl ns (Instance instfc ty decls) = processInstance ns instfc ty decls processDecl ns (ShortData fc lhs sigs) = processShortData ns fc lhs sigs processDecl ns (Data fc nm ty cons) = processData ns fc nm ty cons processDecl ns (Record recordFC nm tele cname decls) = processRecord ns recordFC nm tele cname decls