split processDecl into separate functions

This commit is contained in:
2025-03-30 11:00:55 -07:00
parent 4ec7519955
commit 654e5cdb25
2 changed files with 42 additions and 25 deletions

View File

@@ -17,7 +17,7 @@
} }
], ],
"@typescript-eslint/semi": "warn", "@typescript-eslint/semi": "warn",
"curly": ["warn", "multi"], "curly": ["warn", "multi", "consistent"],
"eqeqeq": "warn", "eqeqeq": "warn",
"no-throw-literal": "warn", "no-throw-literal": "warn",
"semi": "off" "semi": "off"

View File

@@ -99,10 +99,8 @@ impTele tele = map foo tele
processDecl : List String -> Decl -> M Unit processDecl : List String -> Decl -> M Unit
-- REVIEW I supposed I could have updated top here instead of the dance with the parser... processTypeSig : List String FC List Name Raw M Unit
processDecl ns (PMixFix _ _ _ _) = pure MkUnit processTypeSig ns fc names tm = do
processDecl ns (TypeSig fc names tm) = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
top <- getTop top <- getTop
@@ -117,13 +115,17 @@ processDecl ns (TypeSig fc names tm) = do
log 1 $ \ _ => "TypeSig \{unwords names} : \{render 90 $ pprint Nil ty}" log 1 $ \ _ => "TypeSig \{unwords names} : \{render 90 $ pprint Nil ty}"
ignore $ for names $ \nm => setDef (QN ns nm) fc ty Axiom ignore $ for names $ \nm => setDef (QN ns nm) fc ty Axiom
processDecl ns (PType fc nm ty) = do
processPrimType : List Name FC Name Maybe Raw M Unit
processPrimType ns fc nm ty = do
top <- getTop top <- getTop
ty' <- check (mkCtx fc) (maybe (RU fc) id ty) (VU fc) ty' <- check (mkCtx fc) (maybe (RU fc) id ty) (VU fc)
let arity = cast $ piArity ty' let arity = cast $ piArity ty'
setDef (QN ns nm) fc ty' (PrimTCon arity) setDef (QN ns nm) fc ty' (PrimTCon arity)
processDecl ns (PFunc fc nm used ty src) = do
processPrimFn : List String FC String List String Raw String M Unit
processPrimFn ns fc nm used ty src = do
top <- getTop top <- getTop
ty <- check (mkCtx fc) ty (VU fc) ty <- check (mkCtx fc) ty (VU fc)
ty' <- nf Nil ty ty' <- nf Nil ty
@@ -135,7 +137,9 @@ processDecl ns (PFunc fc nm used ty src) = do
let arity = piArity ty' let arity = piArity ty'
setDef (QN ns nm) fc ty' (PrimFn src arity used') setDef (QN ns nm) fc ty' (PrimFn src arity used')
processDecl ns (Def fc nm clauses) = do
processDef : List String FC String List (Raw × Raw) M Unit
processDef ns fc nm clauses = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
log 1 $ \ _ => "Def \{show nm}" log 1 $ \ _ => "Def \{show nm}"
top <- getTop top <- getTop
@@ -169,7 +173,8 @@ processDecl ns (Def fc nm clauses) = do
debug $ \ _ => "Add def \{nm} \{render 90 $ pprint Nil tm'} : \{render 90 $ pprint Nil ty}" debug $ \ _ => "Add def \{nm} \{render 90 $ pprint Nil tm'} : \{render 90 $ pprint Nil ty}"
updateDef (QN ns nm) fc ty (Fn tm') updateDef (QN ns nm) fc ty (Fn tm')
processDecl ns (DCheck fc tm ty) = do processCheck : List String FC Raw Raw M Unit
processCheck ns fc tm ty = do
log 1 $ \ _ => "----- DCheck" log 1 $ \ _ => "----- DCheck"
top <- getTop top <- getTop
@@ -184,7 +189,9 @@ processDecl ns (DCheck fc tm ty) = do
norm <- nfv Nil res norm <- nfv Nil res
putStrLn " NFV \{render 90 $ pprint Nil norm}" putStrLn " NFV \{render 90 $ pprint Nil norm}"
processDecl ns (Class classFC nm tele decls) = do
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 -- REVIEW maybe we can leverage Record for this
-- a couple of catches, we don't want the dotted accessors and -- a couple of catches, we don't want the dotted accessors and
-- the self argument should be an auto-implicit -- the self argument should be an auto-implicit
@@ -230,9 +237,8 @@ processDecl ns (Class classFC nm tele decls) = do
mkApp : Raw BindInfo × Raw Raw mkApp : Raw BindInfo × Raw Raw
mkApp acc (BI fc nm icit _, _) = RApp fc acc (RVar fc nm) icit mkApp acc (BI fc nm icit _, _) = RApp fc acc (RVar fc nm) icit
-- TODO - these are big, break them out into individual functions processInstance : List String FC Raw Maybe (List Decl) M Unit
processDecl ns (Instance instfc ty decls) = do processInstance ns instfc ty decls = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
log 1 $ \ _ => "Instance \{render 90 $ pretty ty}" log 1 $ \ _ => "Instance \{render 90 $ pretty ty}"
top <- getTop top <- getTop
@@ -340,7 +346,9 @@ processDecl ns (Instance instfc ty decls) = do
apply bx xs apply bx xs
apply x (y :: xs) = error instfc "expected pi type \{show x}" apply x (y :: xs) = error instfc "expected pi type \{show x}"
processDecl ns (ShortData fc lhs sigs) = do -- 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 (nm,args) <- getArgs lhs Nil
let ty = foldr mkPi (RU fc) args let ty = foldr mkPi (RU fc) args
cons <- traverse (mkDecl args Nil) sigs cons <- traverse (mkDecl args Nil) sigs
@@ -369,7 +377,9 @@ processDecl ns (ShortData fc lhs sigs) = do
mkDecl args acc (RApp fc' t u icit) = mkDecl args (u :: acc) t 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}" mkDecl args acc tm = error (getFC tm) "Expected contructor application, got: \{show tm}"
processDecl ns (Data fc nm ty cons) = do
processData : List String FC String Raw List Decl M Unit
processData ns fc nm ty cons = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
log 1 $ \ _ => "Data \{nm}" log 1 $ \ _ => "Data \{nm}"
top <- getTop top <- getTop
@@ -414,7 +424,9 @@ processDecl ns (Data fc nm ty cons) = do
checkDeclType (Pi _ str icit rig t u) = checkDeclType u checkDeclType (Pi _ str icit rig t u) = checkDeclType u
checkDeclType _ = error fc "data type doesn't return U" checkDeclType _ = error fc "data type doesn't return U"
processDecl ns (Record recordFC nm tele cname decls) = do
processRecord : List String FC String Telescope Maybe Name List Decl M Unit
processRecord ns recordFC nm tele cname decls = do
log 1 $ \ _ => "-----" log 1 $ \ _ => "-----"
log 1 $ \ _ => "Record" log 1 $ \ _ => "Record"
let fields = getSigs decls let fields = getSigs decls
@@ -438,15 +450,6 @@ processDecl ns (Record recordFC nm tele cname decls) = do
let funType = teleToPi (impTele tele) $ RPi fc (BI fc "_" Explicit Many) tail ty 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 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` - consider dropping to keep namespace clean
-- let lhs = foldl (\acc, (BI fc' nm icit quant, _) => RApp fc' acc (RVar fc' nm) Implicit) (RVar fc name) tele
-- let lhs = RApp recordFC lhs autoPat Explicit
-- let decl = Def fc name [(lhs, (RVar fc name))]
-- log 1 $ \ _ => "\{name} : \{render 90 $ pretty funType}"
-- log 1 $ \ _ => "\{render 90 $ pretty decl}"
-- processDecl ns $ TypeSig fc (name :: Nil) funType
-- processDecl ns decl
-- `.fieldName` -- `.fieldName`
let pname = "." ++ name 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 = 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
@@ -456,3 +459,17 @@ processDecl ns (Record recordFC nm tele cname decls) = do
log 1 $ \ _ => "\{render 90 $ pretty pdecl}" log 1 $ \ _ => "\{render 90 $ pretty pdecl}"
processDecl ns $ TypeSig fc (pname :: Nil) funType processDecl ns $ TypeSig fc (pname :: Nil) funType
processDecl ns pdecl processDecl ns pdecl
-- 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 (Def 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