git.iko.soy/Idris-dev
on master help sign in
Recognise instance constructors in Compiler.hs.
commitcee59856e6b29afb65ff587f9faa4eaec89662fd authorMatus Tejiscak <ziman@functor.sk> dateMon 10 Mar 2014, 15:50 (13 years ago) parent5bdfe51
2 files changed+20−10
compare with master
unifiedsplit
src/IRTS/Compiler.hs+14−4 src/Idris/Erasure.hs+6−6
src/IRTS/Compiler.hs+14−4
@@ -315,7 +315,6 @@ irTerm vs env (Constant c) = return $ LConst c
315315irTerm vs env (TType _) = return $ LNothing
316316irTerm vs env Erased = return $ LNothing
317317irTerm vs env Impossible = return $ LNothing
318−-- ir' env _ = return $ LError "Impossible"
319318
320319irCon :: Vars -> [Name] -> Int -> Name -> [Term] -> Idris LExp
321320irCon vs env arity n args
@@ -472,9 +471,20 @@ irAlt :: Vars -> LExp -> CaseAlt -> Idris LAlt
472471
473472-- this leaves out all unused arguments of the constructor
474473irAlt vs _ (ConCase n t args sc) = do
475− sc' <- irSC vs sc
476− used <- maybe [] (map fst . usedpos) . lookupCtxtExact n . idris_callgraph <$> getIState
477− return $ LConCase (-1) n [a | (i,a) <- zip [0..] args, i `elem` used] sc'
474+ used <- getUsed . lookup n <$> getIState
475+ let usedArgs = [a | (i,a) <- zip [0..] args, i `elem` used]
476+ LConCase (-1) n usedArgs <$> irSC (methodVars `M.union` vs) sc
477+ where
478+ lookup n = lookupCtxtExact n . idris_callgraph
479+ getUsed = maybe [] (map fst . usedpos)
480+
481+ methodVars = case n of
482+ SN (InstanceCtorN className)
483+ -> M.fromList [(v, VI
484+ { viMethod = Just $ mkFieldName n i
485+ }) | (v,i) <- zip args [0..]]
486+ _
487+ -> M.empty -- not an instance constructor
478488
479489irAlt vs _ (ConstCase x rhs)
480490 | matchable x = LConstCase x <$> irSC vs rhs
src/Idris/Erasure.hs+6−6
@@ -1,6 +1,6 @@
11{-# LANGUAGE PatternGuards #-}
22
3−module Idris.Erasure (performUsageAnalysis) where
3+module Idris.Erasure (performUsageAnalysis, mkFieldName) where
44
55import Idris.AbsSyntax
66import Idris.Core.CaseTree
@@ -306,7 +306,7 @@ buildDepMap ci ctx mainName = addPostulates $ dfs S.empty M.empty [mainName]
306306
307307 -- generate metamethod names, "n" is the instance ctor
308308 meth :: Int -> Maybe Name
309− meth | SN (InstanceCtorN className) <- n = \j -> Just (mkField n j)
309+ meth | SN (InstanceCtorN className) <- n = \j -> Just (mkFieldName n j)
310310 | otherwise = \j -> Nothing
311311
312312 -- Named variables -> DeBruijn variables -> Conds/guards -> Term -> Deps
@@ -423,7 +423,7 @@ buildDepMap ci ctx mainName = addPostulates $ dfs S.empty M.empty [mainName]
423423 deps i = M.singleton (metameth, Arg i) S.empty
424424 bruijns = reverse [\cd -> M.singleton cd (deps i) | i <- [0 .. length args - 1]]
425425 cond = S.singleton (metameth, Result)
426− metameth = mkField ctorName methNo
426+ metameth = mkFieldName ctorName methNo
427427 (args, body) = unfoldLams t
428428
429429 -- projections
@@ -471,9 +471,6 @@ buildDepMap ci ctx mainName = addPostulates $ dfs S.empty M.empty [mainName]
471471 unfoldLams (Bind n (Lam ty) t) = let (ns,t') = unfoldLams t in (n:ns, t')
472472 unfoldLams t = ([], t)
473473
474− mkField :: Name -> Int -> Name
475− mkField ctorName fieldNo = SN (WhereN fieldNo ctorName $ sMN fieldNo "field")
476−
477474 union :: Deps -> Deps -> Deps
478475 union = M.unionWith (M.unionWith S.union)
479476
@@ -482,3 +479,6 @@ buildDepMap ci ctx mainName = addPostulates $ dfs S.empty M.empty [mainName]
482479
483480 unionMap :: (a -> Deps) -> [a] -> Deps
484481 unionMap f = M.unionsWith (M.unionWith S.union) . map f
482+
483+mkFieldName :: Name -> Int -> Name
484+mkFieldName ctorName fieldNo = SN (WhereN fieldNo ctorName $ sMN fieldNo "field")